1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
29 /* transfer.c -- Top level handling of data transfer statements. */
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
51 statement. For READ (and for backwards compatibily: for WRITE), one has
56 transfer_character_wide
64 transfer_integer_write
65 transfer_logical_write
66 transfer_character_write
67 transfer_character_wide_write
69 transfer_complex_write
70 transfer_real128_write
71 transfer_complex128_write
73 These subroutines do not return status. The *128 functions
74 are in the file transfer128.c.
76 The last call is a call to st_[read|write]_done(). While
77 something can easily go wrong with the initial st_read() or
78 st_write(), an error inhibits any data from actually being
81 extern void transfer_integer (st_parameter_dt
*, void *, int);
82 export_proto(transfer_integer
);
84 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
85 export_proto(transfer_integer_write
);
87 extern void transfer_real (st_parameter_dt
*, void *, int);
88 export_proto(transfer_real
);
90 extern void transfer_real_write (st_parameter_dt
*, void *, int);
91 export_proto(transfer_real_write
);
93 extern void transfer_logical (st_parameter_dt
*, void *, int);
94 export_proto(transfer_logical
);
96 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
97 export_proto(transfer_logical_write
);
99 extern void transfer_character (st_parameter_dt
*, void *, int);
100 export_proto(transfer_character
);
102 extern void transfer_character_write (st_parameter_dt
*, void *, int);
103 export_proto(transfer_character_write
);
105 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
106 export_proto(transfer_character_wide
);
108 extern void transfer_character_wide_write (st_parameter_dt
*,
110 export_proto(transfer_character_wide_write
);
112 extern void transfer_complex (st_parameter_dt
*, void *, int);
113 export_proto(transfer_complex
);
115 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
116 export_proto(transfer_complex_write
);
118 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
120 export_proto(transfer_array
);
122 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
124 export_proto(transfer_array_write
);
126 static void us_read (st_parameter_dt
*, int);
127 static void us_write (st_parameter_dt
*, int);
128 static void next_record_r_unf (st_parameter_dt
*, int);
129 static void next_record_w_unf (st_parameter_dt
*, int);
131 static const st_option advance_opt
[] = {
132 {"yes", ADVANCE_YES
},
138 static const st_option decimal_opt
[] = {
139 {"point", DECIMAL_POINT
},
140 {"comma", DECIMAL_COMMA
},
144 static const st_option round_opt
[] = {
146 {"down", ROUND_DOWN
},
147 {"zero", ROUND_ZERO
},
148 {"nearest", ROUND_NEAREST
},
149 {"compatible", ROUND_COMPATIBLE
},
150 {"processor_defined", ROUND_PROCDEFINED
},
155 static const st_option sign_opt
[] = {
157 {"suppress", SIGN_SS
},
158 {"processor_defined", SIGN_S
},
162 static const st_option blank_opt
[] = {
163 {"null", BLANK_NULL
},
164 {"zero", BLANK_ZERO
},
168 static const st_option delim_opt
[] = {
169 {"apostrophe", DELIM_APOSTROPHE
},
170 {"quote", DELIM_QUOTE
},
171 {"none", DELIM_NONE
},
175 static const st_option pad_opt
[] = {
182 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
183 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
189 current_mode (st_parameter_dt
*dtp
)
193 m
= FORM_UNSPECIFIED
;
195 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
197 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
198 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
200 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
202 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
203 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
205 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
207 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
208 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
215 /* Mid level data transfer statements. */
217 /* Read sequential file - internal unit */
220 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
222 static char *empty_string
[0];
226 /* Zero size array gives internal unit len of 0. Nothing to read. */
227 if (dtp
->internal_unit_len
== 0
228 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
231 /* If we have seen an eor previously, return a length of 0. The
232 caller is responsible for correctly padding the input field. */
233 if (dtp
->u
.p
.sf_seen_eor
)
236 /* Just return something that isn't a NULL pointer, otherwise the
237 caller thinks an error occured. */
238 return (char*) empty_string
;
242 if (is_char4_unit(dtp
))
245 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
247 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
248 for (i
= 0; i
< *length
; i
++, p
++)
249 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
252 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
254 if (unlikely (lorig
> *length
))
260 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
262 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
263 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
269 /* When reading sequential formatted records we have a problem. We
270 don't know how long the line is until we read the trailing newline,
271 and we don't want to read too much. If we read too much, we might
272 have to do a physical seek backwards depending on how much data is
273 present, and devices like terminals aren't seekable and would cause
276 Given this, the solution is to read a byte at a time, stopping if
277 we hit the newline. For small allocations, we use a static buffer.
278 For larger allocations, we are forced to allocate memory on the
279 heap. Hopefully this won't happen very often. */
281 /* Read sequential file - external unit */
284 read_sf (st_parameter_dt
*dtp
, int * length
)
286 static char *empty_string
[0];
288 int n
, lorig
, seen_comma
;
290 /* If we have seen an eor previously, return a length of 0. The
291 caller is responsible for correctly padding the input field. */
292 if (dtp
->u
.p
.sf_seen_eor
)
295 /* Just return something that isn't a NULL pointer, otherwise the
296 caller thinks an error occured. */
297 return (char*) empty_string
;
302 /* Read data into format buffer and scan through it. */
307 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
310 else if (q
== '\n' || q
== '\r')
312 /* Unexpected end of line. Set the position. */
313 dtp
->u
.p
.sf_seen_eor
= 1;
315 /* If we see an EOR during non-advancing I/O, we need to skip
316 the rest of the I/O statement. Set the corresponding flag. */
317 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
318 dtp
->u
.p
.eor_condition
= 1;
320 /* If we encounter a CR, it might be a CRLF. */
321 if (q
== '\r') /* Probably a CRLF */
323 /* See if there is an LF. */
324 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
326 dtp
->u
.p
.sf_seen_eor
= 2;
327 else if (q2
!= EOF
) /* Oops, seek back. */
328 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
331 /* Without padding, terminate the I/O statement without assigning
332 the value. With padding, the value still needs to be assigned,
333 so we can just continue with a short read. */
334 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
336 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
343 /* Short circuit the read if a comma is found during numeric input.
344 The flag is set to zero during character reads so that commas in
345 strings are not ignored */
347 if (dtp
->u
.p
.sf_read_comma
== 1)
350 notify_std (&dtp
->common
, GFC_STD_GNU
,
351 "Comma in formatted numeric read.");
359 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
360 some other stuff. Set the relevant flags. */
361 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
365 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
367 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
373 dtp
->u
.p
.eor_condition
= 1;
378 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
379 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
380 || dtp
->u
.p
.current_unit
->bytes_left
381 == dtp
->u
.p
.current_unit
->recl
)
390 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
392 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
393 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
395 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
396 fbuf_getc might reallocate the buffer. So return current pointer
397 minus all the advances, which is n plus up to two characters
398 of newline or comma. */
399 return fbuf_getptr (dtp
->u
.p
.current_unit
)
400 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
404 /* Function for reading the next couple of bytes from the current
405 file, advancing the current position. We return FAILURE on end of record or
406 end of file. This function is only for formatted I/O, unformatted uses
409 If the read is short, then it is because the current record does not
410 have enough data to satisfy the read request and the file was
411 opened with PAD=YES. The caller must assume tailing spaces for
415 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
420 if (!is_stream_io (dtp
))
422 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
424 /* For preconnected units with default record length, set bytes left
425 to unit record length and proceed, otherwise error. */
426 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
427 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
428 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
431 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
432 && !is_internal_unit (dtp
))
434 /* Not enough data left. */
435 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
440 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
441 && !is_internal_unit(dtp
)))
447 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
451 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
452 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
453 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
455 if (is_internal_unit (dtp
))
456 source
= read_sf_internal (dtp
, nbytes
);
458 source
= read_sf (dtp
, nbytes
);
460 dtp
->u
.p
.current_unit
->strm_pos
+=
461 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
465 /* If we reach here, we can assume it's direct access. */
467 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
470 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
471 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
473 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
474 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
476 if (norig
!= *nbytes
)
478 /* Short read, this shouldn't happen. */
479 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
481 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
486 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
492 /* Read a block from a character(kind=4) internal unit, to be transferred into
493 a character(kind=4) variable. Note: Portions of this code borrowed from
496 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
498 static gfc_char4_t
*empty_string
[0];
502 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
503 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
505 /* Zero size array gives internal unit len of 0. Nothing to read. */
506 if (dtp
->internal_unit_len
== 0
507 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
510 /* If we have seen an eor previously, return a length of 0. The
511 caller is responsible for correctly padding the input field. */
512 if (dtp
->u
.p
.sf_seen_eor
)
515 /* Just return something that isn't a NULL pointer, otherwise the
516 caller thinks an error occured. */
521 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
523 if (unlikely (lorig
> *nbytes
))
529 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
531 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
532 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
538 /* Reads a block directly into application data space. This is for
539 unformatted files. */
542 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
544 ssize_t to_read_record
;
545 ssize_t have_read_record
;
546 ssize_t to_read_subrecord
;
547 ssize_t have_read_subrecord
;
550 if (is_stream_io (dtp
))
552 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
554 if (unlikely (have_read_record
< 0))
556 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
560 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
562 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
564 /* Short read, e.g. if we hit EOF. For stream files,
565 we have to set the end-of-file condition. */
571 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
573 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
576 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
577 nbytes
= to_read_record
;
582 to_read_record
= nbytes
;
585 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
587 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
588 if (unlikely (to_read_record
< 0))
590 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
594 if (to_read_record
!= (ssize_t
) nbytes
)
596 /* Short read, e.g. if we hit EOF. Apparently, we read
597 more than was written to the last record. */
601 if (unlikely (short_record
))
603 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
608 /* Unformatted sequential. We loop over the subrecords, reading
609 until the request has been fulfilled or the record has run out
610 of continuation subrecords. */
612 /* Check whether we exceed the total record length. */
614 if (dtp
->u
.p
.current_unit
->flags
.has_recl
615 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
617 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
622 to_read_record
= nbytes
;
625 have_read_record
= 0;
629 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
630 < (gfc_offset
) to_read_record
)
632 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
633 to_read_record
-= to_read_subrecord
;
637 to_read_subrecord
= to_read_record
;
641 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
643 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
644 buf
+ have_read_record
, to_read_subrecord
);
645 if (unlikely (have_read_subrecord
) < 0)
647 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
651 have_read_record
+= have_read_subrecord
;
653 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
655 /* Short read, e.g. if we hit EOF. This means the record
656 structure has been corrupted, or the trailing record
657 marker would still be present. */
659 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
663 if (to_read_record
> 0)
665 if (likely (dtp
->u
.p
.current_unit
->continued
))
667 next_record_r_unf (dtp
, 0);
672 /* Let's make sure the file position is correctly pre-positioned
673 for the next read statement. */
675 dtp
->u
.p
.current_unit
->current_record
= 0;
676 next_record_r_unf (dtp
, 0);
677 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
683 /* Normal exit, the read request has been fulfilled. */
688 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
689 if (unlikely (short_record
))
691 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
698 /* Function for writing a block of bytes to the current file at the
699 current position, advancing the file pointer. We are given a length
700 and return a pointer to a buffer that the caller must (completely)
701 fill in. Returns NULL on error. */
704 write_block (st_parameter_dt
*dtp
, int length
)
708 if (!is_stream_io (dtp
))
710 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
712 /* For preconnected units with default record length, set bytes left
713 to unit record length and proceed, otherwise error. */
714 if (likely ((dtp
->u
.p
.current_unit
->unit_number
715 == options
.stdout_unit
716 || dtp
->u
.p
.current_unit
->unit_number
717 == options
.stderr_unit
)
718 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
719 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
722 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
727 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
730 if (is_internal_unit (dtp
))
732 if (dtp
->common
.unit
) /* char4 internel unit. */
735 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
738 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
744 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
748 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
752 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
753 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
757 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
760 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
765 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
766 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
768 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
774 /* High level interface to swrite(), taking care of errors. This is only
775 called for unformatted files. There are three cases to consider:
776 Stream I/O, unformatted direct, unformatted sequential. */
779 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
782 ssize_t have_written
;
783 ssize_t to_write_subrecord
;
788 if (is_stream_io (dtp
))
790 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
791 if (unlikely (have_written
< 0))
793 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
797 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
802 /* Unformatted direct access. */
804 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
806 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
808 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
812 if (buf
== NULL
&& nbytes
== 0)
815 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
816 if (unlikely (have_written
< 0))
818 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
822 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
823 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
828 /* Unformatted sequential. */
832 if (dtp
->u
.p
.current_unit
->flags
.has_recl
833 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
835 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
847 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
848 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
850 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
851 (gfc_offset
) to_write_subrecord
;
853 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
854 buf
+ have_written
, to_write_subrecord
);
855 if (unlikely (to_write_subrecord
< 0))
857 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
861 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
862 nbytes
-= to_write_subrecord
;
863 have_written
+= to_write_subrecord
;
868 next_record_w_unf (dtp
, 1);
871 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
872 if (unlikely (short_record
))
874 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
881 /* Master function for unformatted reads. */
884 unformatted_read (st_parameter_dt
*dtp
, bt type
,
885 void *dest
, int kind
, size_t size
, size_t nelems
)
887 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
890 if (type
== BT_CHARACTER
)
891 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
892 read_block_direct (dtp
, dest
, size
* nelems
);
902 /* Handle wide chracters. */
903 if (type
== BT_CHARACTER
&& kind
!= 1)
909 /* Break up complex into its constituent reals. */
910 if (type
== BT_COMPLEX
)
916 /* By now, all complex variables have been split into their
917 constituent reals. */
919 for (i
= 0; i
< nelems
; i
++)
921 read_block_direct (dtp
, buffer
, size
);
922 reverse_memcpy (p
, buffer
, size
);
929 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
930 bytes on 64 bit machines. The unused bytes are not initialized and never
931 used, which can show an error with memory checking analyzers like
935 unformatted_write (st_parameter_dt
*dtp
, bt type
,
936 void *source
, int kind
, size_t size
, size_t nelems
)
938 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
941 size_t stride
= type
== BT_CHARACTER
?
942 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
944 write_buf (dtp
, source
, stride
* nelems
);
954 /* Handle wide chracters. */
955 if (type
== BT_CHARACTER
&& kind
!= 1)
961 /* Break up complex into its constituent reals. */
962 if (type
== BT_COMPLEX
)
968 /* By now, all complex variables have been split into their
969 constituent reals. */
971 for (i
= 0; i
< nelems
; i
++)
973 reverse_memcpy(buffer
, p
, size
);
975 write_buf (dtp
, buffer
, size
);
981 /* Return a pointer to the name of a type. */
1006 internal_error (NULL
, "type_name(): Bad type");
1013 /* Write a constant string to the output.
1014 This is complicated because the string can have doubled delimiters
1015 in it. The length in the format node is the true length. */
1018 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1020 char c
, delimiter
, *p
, *q
;
1023 length
= f
->u
.string
.length
;
1027 p
= write_block (dtp
, length
);
1034 for (; length
> 0; length
--)
1037 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1038 q
++; /* Skip the doubled delimiter. */
1043 /* Given actual and expected types in a formatted data transfer, make
1044 sure they agree. If not, an error message is generated. Returns
1045 nonzero if something went wrong. */
1048 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1052 if (actual
== expected
)
1055 /* Adjust item_count before emitting error message. */
1056 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
1057 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1059 format_error (dtp
, f
, buffer
);
1064 /* This function is in the main loop for a formatted data transfer
1065 statement. It would be natural to implement this as a coroutine
1066 with the user program, but C makes that awkward. We loop,
1067 processing format elements. When we actually have to transfer
1068 data instead of just setting flags, we return control to the user
1069 program which calls a function that supplies the address and type
1070 of the next element, then comes back here to process it. */
1073 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1076 int pos
, bytes_used
;
1080 int consume_data_flag
;
1082 /* Change a complex data item into a pair of reals. */
1084 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1085 if (type
== BT_COMPLEX
)
1091 /* If there's an EOR condition, we simulate finalizing the transfer
1092 by doing nothing. */
1093 if (dtp
->u
.p
.eor_condition
)
1096 /* Set this flag so that commas in reads cause the read to complete before
1097 the entire field has been read. The next read field will start right after
1098 the comma in the stream. (Set to 0 for character reads). */
1099 dtp
->u
.p
.sf_read_comma
=
1100 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1104 /* If reversion has occurred and there is another real data item,
1105 then we have to move to the next record. */
1106 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1108 dtp
->u
.p
.reversion_flag
= 0;
1109 next_record (dtp
, 0);
1112 consume_data_flag
= 1;
1113 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1116 f
= next_format (dtp
);
1119 /* No data descriptors left. */
1120 if (unlikely (n
> 0))
1121 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1122 "Insufficient data descriptors in format after reversion");
1128 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1129 - dtp
->u
.p
.current_unit
->bytes_left
);
1131 if (is_stream_io(dtp
))
1138 goto need_read_data
;
1139 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1141 read_decimal (dtp
, f
, p
, kind
);
1146 goto need_read_data
;
1147 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1148 && require_type (dtp
, BT_INTEGER
, type
, f
))
1150 read_radix (dtp
, f
, p
, kind
, 2);
1155 goto need_read_data
;
1156 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1157 && require_type (dtp
, BT_INTEGER
, type
, f
))
1159 read_radix (dtp
, f
, p
, kind
, 8);
1164 goto need_read_data
;
1165 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1166 && require_type (dtp
, BT_INTEGER
, type
, f
))
1168 read_radix (dtp
, f
, p
, kind
, 16);
1173 goto need_read_data
;
1175 /* It is possible to have FMT_A with something not BT_CHARACTER such
1176 as when writing out hollerith strings, so check both type
1177 and kind before calling wide character routines. */
1178 if (type
== BT_CHARACTER
&& kind
== 4)
1179 read_a_char4 (dtp
, f
, p
, size
);
1181 read_a (dtp
, f
, p
, size
);
1186 goto need_read_data
;
1187 read_l (dtp
, f
, p
, kind
);
1192 goto need_read_data
;
1193 if (require_type (dtp
, BT_REAL
, type
, f
))
1195 read_f (dtp
, f
, p
, kind
);
1200 goto need_read_data
;
1201 if (require_type (dtp
, BT_REAL
, type
, f
))
1203 read_f (dtp
, f
, p
, kind
);
1208 goto need_read_data
;
1209 if (require_type (dtp
, BT_REAL
, type
, f
))
1211 read_f (dtp
, f
, p
, kind
);
1216 goto need_read_data
;
1217 if (require_type (dtp
, BT_REAL
, type
, f
))
1219 read_f (dtp
, f
, p
, kind
);
1224 goto need_read_data
;
1225 if (require_type (dtp
, BT_REAL
, type
, f
))
1227 read_f (dtp
, f
, p
, kind
);
1232 goto need_read_data
;
1236 read_decimal (dtp
, f
, p
, kind
);
1239 read_l (dtp
, f
, p
, kind
);
1243 read_a_char4 (dtp
, f
, p
, size
);
1245 read_a (dtp
, f
, p
, size
);
1248 read_f (dtp
, f
, p
, kind
);
1251 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1256 consume_data_flag
= 0;
1257 format_error (dtp
, f
, "Constant string in input format");
1260 /* Format codes that don't transfer data. */
1263 consume_data_flag
= 0;
1264 dtp
->u
.p
.skips
+= f
->u
.n
;
1265 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1266 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1267 read_x (dtp
, f
->u
.n
);
1272 consume_data_flag
= 0;
1274 if (f
->format
== FMT_TL
)
1276 /* Handle the special case when no bytes have been used yet.
1277 Cannot go below zero. */
1278 if (bytes_used
== 0)
1280 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1281 dtp
->u
.p
.skips
-= f
->u
.n
;
1282 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1285 pos
= bytes_used
- f
->u
.n
;
1290 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1291 left tab limit. We do not check if the position has gone
1292 beyond the end of record because a subsequent tab could
1293 bring us back again. */
1294 pos
= pos
< 0 ? 0 : pos
;
1296 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1297 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1298 + pos
- dtp
->u
.p
.max_pos
;
1299 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1300 ? 0 : dtp
->u
.p
.pending_spaces
;
1301 if (dtp
->u
.p
.skips
== 0)
1304 /* Adjust everything for end-of-record condition */
1305 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1307 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1308 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1310 dtp
->u
.p
.sf_seen_eor
= 0;
1312 if (dtp
->u
.p
.skips
< 0)
1314 if (is_internal_unit (dtp
))
1315 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1317 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1318 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1319 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1322 read_x (dtp
, dtp
->u
.p
.skips
);
1326 consume_data_flag
= 0;
1327 dtp
->u
.p
.sign_status
= SIGN_S
;
1331 consume_data_flag
= 0;
1332 dtp
->u
.p
.sign_status
= SIGN_SS
;
1336 consume_data_flag
= 0;
1337 dtp
->u
.p
.sign_status
= SIGN_SP
;
1341 consume_data_flag
= 0 ;
1342 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1346 consume_data_flag
= 0;
1347 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1351 consume_data_flag
= 0;
1352 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1356 consume_data_flag
= 0;
1357 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1361 consume_data_flag
= 0;
1362 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1366 consume_data_flag
= 0;
1367 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1371 consume_data_flag
= 0;
1372 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1376 consume_data_flag
= 0;
1377 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1381 consume_data_flag
= 0;
1382 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1386 consume_data_flag
= 0;
1387 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1391 consume_data_flag
= 0;
1392 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1396 consume_data_flag
= 0;
1397 dtp
->u
.p
.seen_dollar
= 1;
1401 consume_data_flag
= 0;
1402 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1403 next_record (dtp
, 0);
1407 /* A colon descriptor causes us to exit this loop (in
1408 particular preventing another / descriptor from being
1409 processed) unless there is another data item to be
1411 consume_data_flag
= 0;
1417 internal_error (&dtp
->common
, "Bad format node");
1420 /* Adjust the item count and data pointer. */
1422 if ((consume_data_flag
> 0) && (n
> 0))
1425 p
= ((char *) p
) + size
;
1430 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1431 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1436 /* Come here when we need a data descriptor but don't have one. We
1437 push the current format node back onto the input, then return and
1438 let the user program call us back with the data. */
1440 unget_format (dtp
, f
);
1445 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1448 int pos
, bytes_used
;
1452 int consume_data_flag
;
1454 /* Change a complex data item into a pair of reals. */
1456 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1457 if (type
== BT_COMPLEX
)
1463 /* If there's an EOR condition, we simulate finalizing the transfer
1464 by doing nothing. */
1465 if (dtp
->u
.p
.eor_condition
)
1468 /* Set this flag so that commas in reads cause the read to complete before
1469 the entire field has been read. The next read field will start right after
1470 the comma in the stream. (Set to 0 for character reads). */
1471 dtp
->u
.p
.sf_read_comma
=
1472 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1476 /* If reversion has occurred and there is another real data item,
1477 then we have to move to the next record. */
1478 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1480 dtp
->u
.p
.reversion_flag
= 0;
1481 next_record (dtp
, 0);
1484 consume_data_flag
= 1;
1485 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1488 f
= next_format (dtp
);
1491 /* No data descriptors left. */
1492 if (unlikely (n
> 0))
1493 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1494 "Insufficient data descriptors in format after reversion");
1498 /* Now discharge T, TR and X movements to the right. This is delayed
1499 until a data producing format to suppress trailing spaces. */
1502 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1503 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1504 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1505 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1506 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1507 || t
== FMT_STRING
))
1509 if (dtp
->u
.p
.skips
> 0)
1512 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1513 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1514 - dtp
->u
.p
.current_unit
->bytes_left
);
1516 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1518 if (dtp
->u
.p
.skips
< 0)
1520 if (is_internal_unit (dtp
))
1521 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1523 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1524 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1526 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1529 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1530 - dtp
->u
.p
.current_unit
->bytes_left
);
1532 if (is_stream_io(dtp
))
1540 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1542 write_i (dtp
, f
, p
, kind
);
1548 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1549 && require_type (dtp
, BT_INTEGER
, type
, f
))
1551 write_b (dtp
, f
, p
, kind
);
1557 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1558 && require_type (dtp
, BT_INTEGER
, type
, f
))
1560 write_o (dtp
, f
, p
, kind
);
1566 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1567 && require_type (dtp
, BT_INTEGER
, type
, f
))
1569 write_z (dtp
, f
, p
, kind
);
1576 /* It is possible to have FMT_A with something not BT_CHARACTER such
1577 as when writing out hollerith strings, so check both type
1578 and kind before calling wide character routines. */
1579 if (type
== BT_CHARACTER
&& kind
== 4)
1580 write_a_char4 (dtp
, f
, p
, size
);
1582 write_a (dtp
, f
, p
, size
);
1588 write_l (dtp
, f
, p
, kind
);
1594 if (require_type (dtp
, BT_REAL
, type
, f
))
1596 write_d (dtp
, f
, p
, kind
);
1602 if (require_type (dtp
, BT_REAL
, type
, f
))
1604 write_e (dtp
, f
, p
, kind
);
1610 if (require_type (dtp
, BT_REAL
, type
, f
))
1612 write_en (dtp
, f
, p
, kind
);
1618 if (require_type (dtp
, BT_REAL
, type
, f
))
1620 write_es (dtp
, f
, p
, kind
);
1626 if (require_type (dtp
, BT_REAL
, type
, f
))
1628 write_f (dtp
, f
, p
, kind
);
1637 write_i (dtp
, f
, p
, kind
);
1640 write_l (dtp
, f
, p
, kind
);
1644 write_a_char4 (dtp
, f
, p
, size
);
1646 write_a (dtp
, f
, p
, size
);
1649 if (f
->u
.real
.w
== 0)
1650 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1652 write_d (dtp
, f
, p
, kind
);
1655 internal_error (&dtp
->common
,
1656 "formatted_transfer(): Bad type");
1661 consume_data_flag
= 0;
1662 write_constant_string (dtp
, f
);
1665 /* Format codes that don't transfer data. */
1668 consume_data_flag
= 0;
1670 dtp
->u
.p
.skips
+= f
->u
.n
;
1671 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1672 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1673 /* Writes occur just before the switch on f->format, above, so
1674 that trailing blanks are suppressed, unless we are doing a
1675 non-advancing write in which case we want to output the blanks
1677 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1679 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1680 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1686 consume_data_flag
= 0;
1688 if (f
->format
== FMT_TL
)
1691 /* Handle the special case when no bytes have been used yet.
1692 Cannot go below zero. */
1693 if (bytes_used
== 0)
1695 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1696 dtp
->u
.p
.skips
-= f
->u
.n
;
1697 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1700 pos
= bytes_used
- f
->u
.n
;
1703 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1705 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1706 left tab limit. We do not check if the position has gone
1707 beyond the end of record because a subsequent tab could
1708 bring us back again. */
1709 pos
= pos
< 0 ? 0 : pos
;
1711 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1712 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1713 + pos
- dtp
->u
.p
.max_pos
;
1714 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1715 ? 0 : dtp
->u
.p
.pending_spaces
;
1719 consume_data_flag
= 0;
1720 dtp
->u
.p
.sign_status
= SIGN_S
;
1724 consume_data_flag
= 0;
1725 dtp
->u
.p
.sign_status
= SIGN_SS
;
1729 consume_data_flag
= 0;
1730 dtp
->u
.p
.sign_status
= SIGN_SP
;
1734 consume_data_flag
= 0 ;
1735 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1739 consume_data_flag
= 0;
1740 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1744 consume_data_flag
= 0;
1745 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1749 consume_data_flag
= 0;
1750 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1754 consume_data_flag
= 0;
1755 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1759 consume_data_flag
= 0;
1760 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1764 consume_data_flag
= 0;
1765 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1769 consume_data_flag
= 0;
1770 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1774 consume_data_flag
= 0;
1775 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1779 consume_data_flag
= 0;
1780 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1784 consume_data_flag
= 0;
1785 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1789 consume_data_flag
= 0;
1790 dtp
->u
.p
.seen_dollar
= 1;
1794 consume_data_flag
= 0;
1795 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1796 next_record (dtp
, 0);
1800 /* A colon descriptor causes us to exit this loop (in
1801 particular preventing another / descriptor from being
1802 processed) unless there is another data item to be
1804 consume_data_flag
= 0;
1810 internal_error (&dtp
->common
, "Bad format node");
1813 /* Adjust the item count and data pointer. */
1815 if ((consume_data_flag
> 0) && (n
> 0))
1818 p
= ((char *) p
) + size
;
1821 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1822 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1827 /* Come here when we need a data descriptor but don't have one. We
1828 push the current format node back onto the input, then return and
1829 let the user program call us back with the data. */
1831 unget_format (dtp
, f
);
1834 /* This function is first called from data_init_transfer to initiate the loop
1835 over each item in the format, transferring data as required. Subsequent
1836 calls to this function occur for each data item foound in the READ/WRITE
1837 statement. The item_count is incremented for each call. Since the first
1838 call is from data_transfer_init, the item_count is always one greater than
1839 the actual count number of the item being transferred. */
1842 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1843 size_t size
, size_t nelems
)
1849 size_t stride
= type
== BT_CHARACTER
?
1850 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1851 if (dtp
->u
.p
.mode
== READING
)
1853 /* Big loop over all the elements. */
1854 for (elem
= 0; elem
< nelems
; elem
++)
1856 dtp
->u
.p
.item_count
++;
1857 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1862 /* Big loop over all the elements. */
1863 for (elem
= 0; elem
< nelems
; elem
++)
1865 dtp
->u
.p
.item_count
++;
1866 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1872 /* Data transfer entry points. The type of the data entity is
1873 implicit in the subroutine call. This prevents us from having to
1874 share a common enum with the compiler. */
1877 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1879 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1881 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1885 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
1887 transfer_integer (dtp
, p
, kind
);
1891 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1894 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1896 size
= size_from_real_kind (kind
);
1897 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1901 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
1903 transfer_real (dtp
, p
, kind
);
1907 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1909 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1911 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1915 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
1917 transfer_logical (dtp
, p
, kind
);
1921 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1923 static char *empty_string
[0];
1925 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1928 /* Strings of zero length can have p == NULL, which confuses the
1929 transfer routines into thinking we need more data elements. To avoid
1930 this, we give them a nice pointer. */
1931 if (len
== 0 && p
== NULL
)
1934 /* Set kind here to 1. */
1935 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1939 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
1941 transfer_character (dtp
, p
, len
);
1945 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1947 static char *empty_string
[0];
1949 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1952 /* Strings of zero length can have p == NULL, which confuses the
1953 transfer routines into thinking we need more data elements. To avoid
1954 this, we give them a nice pointer. */
1955 if (len
== 0 && p
== NULL
)
1958 /* Here we pass the actual kind value. */
1959 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1963 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1965 transfer_character_wide (dtp
, p
, len
, kind
);
1969 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1972 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1974 size
= size_from_complex_kind (kind
);
1975 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1979 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
1981 transfer_complex (dtp
, p
, kind
);
1985 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1986 gfc_charlen_type charlen
)
1988 index_type count
[GFC_MAX_DIMENSIONS
];
1989 index_type extent
[GFC_MAX_DIMENSIONS
];
1990 index_type stride
[GFC_MAX_DIMENSIONS
];
1991 index_type stride0
, rank
, size
, n
;
1996 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1999 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2000 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2002 rank
= GFC_DESCRIPTOR_RANK (desc
);
2003 for (n
= 0; n
< rank
; n
++)
2006 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2007 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2009 /* If the extent of even one dimension is zero, then the entire
2010 array section contains zero elements, so we return after writing
2011 a zero array record. */
2016 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2021 stride0
= stride
[0];
2023 /* If the innermost dimension has a stride of 1, we can do the transfer
2024 in contiguous chunks. */
2025 if (stride0
== size
)
2030 data
= GFC_DESCRIPTOR_DATA (desc
);
2034 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2035 data
+= stride0
* tsize
;
2038 while (count
[n
] == extent
[n
])
2041 data
-= stride
[n
] * extent
[n
];
2058 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2059 gfc_charlen_type charlen
)
2061 transfer_array (dtp
, desc
, kind
, charlen
);
2064 /* Preposition a sequential unformatted file while reading. */
2067 us_read (st_parameter_dt
*dtp
, int continued
)
2074 if (compile_options
.record_marker
== 0)
2075 n
= sizeof (GFC_INTEGER_4
);
2077 n
= compile_options
.record_marker
;
2079 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2080 if (unlikely (nr
< 0))
2082 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2088 return; /* end of file */
2090 else if (unlikely (n
!= nr
))
2092 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2096 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2097 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2101 case sizeof(GFC_INTEGER_4
):
2102 memcpy (&i4
, &i
, sizeof (i4
));
2106 case sizeof(GFC_INTEGER_8
):
2107 memcpy (&i8
, &i
, sizeof (i8
));
2112 runtime_error ("Illegal value for record marker");
2119 case sizeof(GFC_INTEGER_4
):
2120 reverse_memcpy (&i4
, &i
, sizeof (i4
));
2124 case sizeof(GFC_INTEGER_8
):
2125 reverse_memcpy (&i8
, &i
, sizeof (i8
));
2130 runtime_error ("Illegal value for record marker");
2136 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2137 dtp
->u
.p
.current_unit
->continued
= 0;
2141 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2142 dtp
->u
.p
.current_unit
->continued
= 1;
2146 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2150 /* Preposition a sequential unformatted file while writing. This
2151 amount to writing a bogus length that will be filled in later. */
2154 us_write (st_parameter_dt
*dtp
, int continued
)
2161 if (compile_options
.record_marker
== 0)
2162 nbytes
= sizeof (GFC_INTEGER_4
);
2164 nbytes
= compile_options
.record_marker
;
2166 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2167 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2169 /* For sequential unformatted, if RECL= was not specified in the OPEN
2170 we write until we have more bytes than can fit in the subrecord
2171 markers, then we write a new subrecord. */
2173 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2174 dtp
->u
.p
.current_unit
->recl_subrecord
;
2175 dtp
->u
.p
.current_unit
->continued
= continued
;
2179 /* Position to the next record prior to transfer. We are assumed to
2180 be before the next record. We also calculate the bytes in the next
2184 pre_position (st_parameter_dt
*dtp
)
2186 if (dtp
->u
.p
.current_unit
->current_record
)
2187 return; /* Already positioned. */
2189 switch (current_mode (dtp
))
2191 case FORMATTED_STREAM
:
2192 case UNFORMATTED_STREAM
:
2193 /* There are no records with stream I/O. If the position was specified
2194 data_transfer_init has already positioned the file. If no position
2195 was specified, we continue from where we last left off. I.e.
2196 there is nothing to do here. */
2199 case UNFORMATTED_SEQUENTIAL
:
2200 if (dtp
->u
.p
.mode
== READING
)
2207 case FORMATTED_SEQUENTIAL
:
2208 case FORMATTED_DIRECT
:
2209 case UNFORMATTED_DIRECT
:
2210 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2214 dtp
->u
.p
.current_unit
->current_record
= 1;
2218 /* Initialize things for a data transfer. This code is common for
2219 both reading and writing. */
2222 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2224 unit_flags u_flags
; /* Used for creating a unit if needed. */
2225 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2226 namelist_info
*ionml
;
2228 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2230 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2232 dtp
->u
.p
.ionml
= ionml
;
2233 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2235 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2238 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2239 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2241 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2242 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2243 { /* Open the unit with some default flags. */
2244 st_parameter_open opp
;
2247 if (dtp
->common
.unit
< 0)
2249 close_unit (dtp
->u
.p
.current_unit
);
2250 dtp
->u
.p
.current_unit
= NULL
;
2251 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2252 "Bad unit number in statement");
2255 memset (&u_flags
, '\0', sizeof (u_flags
));
2256 u_flags
.access
= ACCESS_SEQUENTIAL
;
2257 u_flags
.action
= ACTION_READWRITE
;
2259 /* Is it unformatted? */
2260 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2261 | IOPARM_DT_IONML_SET
)))
2262 u_flags
.form
= FORM_UNFORMATTED
;
2264 u_flags
.form
= FORM_UNSPECIFIED
;
2266 u_flags
.delim
= DELIM_UNSPECIFIED
;
2267 u_flags
.blank
= BLANK_UNSPECIFIED
;
2268 u_flags
.pad
= PAD_UNSPECIFIED
;
2269 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2270 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2271 u_flags
.async
= ASYNC_UNSPECIFIED
;
2272 u_flags
.round
= ROUND_UNSPECIFIED
;
2273 u_flags
.sign
= SIGN_UNSPECIFIED
;
2275 u_flags
.status
= STATUS_UNKNOWN
;
2277 conv
= get_unformatted_convert (dtp
->common
.unit
);
2279 if (conv
== GFC_CONVERT_NONE
)
2280 conv
= compile_options
.convert
;
2282 /* We use big_endian, which is 0 on little-endian machines
2283 and 1 on big-endian machines. */
2286 case GFC_CONVERT_NATIVE
:
2287 case GFC_CONVERT_SWAP
:
2290 case GFC_CONVERT_BIG
:
2291 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2294 case GFC_CONVERT_LITTLE
:
2295 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2299 internal_error (&opp
.common
, "Illegal value for CONVERT");
2303 u_flags
.convert
= conv
;
2305 opp
.common
= dtp
->common
;
2306 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2307 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2308 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2309 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2310 if (dtp
->u
.p
.current_unit
== NULL
)
2314 /* Check the action. */
2316 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2318 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2319 "Cannot read from file opened for WRITE");
2323 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2325 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2326 "Cannot write to file opened for READ");
2330 dtp
->u
.p
.first_item
= 1;
2332 /* Check the format. */
2334 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2337 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2338 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2341 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2342 "Format present for UNFORMATTED data transfer");
2346 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2348 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2349 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2350 "A format cannot be specified with a namelist");
2352 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2353 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2355 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2356 "Missing format for FORMATTED data transfer");
2359 if (is_internal_unit (dtp
)
2360 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2362 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2363 "Internal file cannot be accessed by UNFORMATTED "
2368 /* Check the record or position number. */
2370 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2371 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2373 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2374 "Direct access data transfer requires record number");
2378 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2380 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2382 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2383 "Record number not allowed for sequential access "
2388 if (dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2390 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2391 "Sequential READ or WRITE not allowed after "
2392 "EOF marker, possibly use REWIND or BACKSPACE");
2397 /* Process the ADVANCE option. */
2399 dtp
->u
.p
.advance_status
2400 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2401 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2402 "Bad ADVANCE parameter in data transfer statement");
2404 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2406 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2408 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2409 "ADVANCE specification conflicts with sequential "
2414 if (is_internal_unit (dtp
))
2416 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2417 "ADVANCE specification conflicts with internal file");
2421 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2422 != IOPARM_DT_HAS_FORMAT
)
2424 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2425 "ADVANCE specification requires an explicit format");
2432 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2434 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2436 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2437 "EOR specification requires an ADVANCE specification "
2442 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2443 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2445 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2446 "SIZE specification requires an ADVANCE "
2447 "specification of NO");
2452 { /* Write constraints. */
2453 if ((cf
& IOPARM_END
) != 0)
2455 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2456 "END specification cannot appear in a write "
2461 if ((cf
& IOPARM_EOR
) != 0)
2463 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2464 "EOR specification cannot appear in a write "
2469 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2471 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2472 "SIZE specification cannot appear in a write "
2478 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2479 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2481 /* Check the decimal mode. */
2482 dtp
->u
.p
.current_unit
->decimal_status
2483 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2484 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2485 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2488 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2489 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2491 /* Check the round mode. */
2492 dtp
->u
.p
.current_unit
->round_status
2493 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2494 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2495 round_opt
, "Bad ROUND parameter in data transfer "
2498 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2499 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2501 /* Check the sign mode. */
2502 dtp
->u
.p
.sign_status
2503 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2504 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2505 "Bad SIGN parameter in data transfer statement");
2507 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2508 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2510 /* Check the blank mode. */
2511 dtp
->u
.p
.blank_status
2512 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2513 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2515 "Bad BLANK parameter in data transfer statement");
2517 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2518 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2520 /* Check the delim mode. */
2521 dtp
->u
.p
.current_unit
->delim_status
2522 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2523 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2524 delim_opt
, "Bad DELIM parameter in data transfer statement");
2526 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2527 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2529 /* Check the pad mode. */
2530 dtp
->u
.p
.current_unit
->pad_status
2531 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2532 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2533 "Bad PAD parameter in data transfer statement");
2535 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2536 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2538 /* Check to see if we might be reading what we wrote before */
2540 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2541 && !is_internal_unit (dtp
))
2543 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2545 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2546 sflush(dtp
->u
.p
.current_unit
->s
);
2549 /* Check the POS= specifier: that it is in range and that it is used with a
2550 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2552 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2554 if (is_stream_io (dtp
))
2559 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2560 "POS=specifier must be positive");
2564 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2566 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2567 "POS=specifier too large");
2571 dtp
->rec
= dtp
->pos
;
2573 if (dtp
->u
.p
.mode
== READING
)
2575 /* Reset the endfile flag; if we hit EOF during reading
2576 we'll set the flag and generate an error at that point
2577 rather than worrying about it here. */
2578 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2581 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2583 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2584 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2586 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2589 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2594 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2595 "POS=specifier not allowed, "
2596 "Try OPEN with ACCESS='stream'");
2602 /* Sanity checks on the record number. */
2603 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2607 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2608 "Record number must be positive");
2612 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2614 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2615 "Record number too large");
2619 /* Make sure format buffer is reset. */
2620 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2621 fbuf_reset (dtp
->u
.p
.current_unit
);
2624 /* Check whether the record exists to be read. Only
2625 a partial record needs to exist. */
2627 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2628 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2630 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2631 "Non-existing record number");
2635 /* Position the file. */
2636 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2637 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2639 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2643 /* TODO: This is required to maintain compatibility between
2644 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2646 if (is_stream_io (dtp
))
2647 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2649 /* TODO: Un-comment this code when ABI changes from 4.3.
2650 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2652 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2653 "Record number not allowed for stream access "
2659 /* Bugware for badly written mixed C-Fortran I/O. */
2660 if (!is_internal_unit (dtp
))
2661 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2663 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2665 /* Set the maximum position reached from the previous I/O operation. This
2666 could be greater than zero from a previous non-advancing write. */
2667 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2672 /* Set up the subroutine that will handle the transfers. */
2676 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2677 dtp
->u
.p
.transfer
= unformatted_read
;
2680 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2682 dtp
->u
.p
.last_char
= EOF
- 1;
2683 dtp
->u
.p
.transfer
= list_formatted_read
;
2686 dtp
->u
.p
.transfer
= formatted_transfer
;
2691 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2692 dtp
->u
.p
.transfer
= unformatted_write
;
2695 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2696 dtp
->u
.p
.transfer
= list_formatted_write
;
2698 dtp
->u
.p
.transfer
= formatted_transfer
;
2702 /* Make sure that we don't do a read after a nonadvancing write. */
2706 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2708 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2709 "Cannot READ after a nonadvancing WRITE");
2715 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2716 dtp
->u
.p
.current_unit
->read_bad
= 1;
2719 /* Start the data transfer if we are doing a formatted transfer. */
2720 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2721 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2722 && dtp
->u
.p
.ionml
== NULL
)
2723 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2726 /* Initialize an array_loop_spec given the array descriptor. The function
2727 returns the index of the last element of the array, and also returns
2728 starting record, where the first I/O goes to (necessary in case of
2729 negative strides). */
2732 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2733 gfc_offset
*start_record
)
2735 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2744 for (i
=0; i
<rank
; i
++)
2746 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2747 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2748 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2749 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2750 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2751 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2753 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2755 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2756 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2760 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2761 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2762 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2763 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2773 /* Determine the index to the next record in an internal unit array by
2774 by incrementing through the array_loop_spec. */
2777 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2785 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2790 if (ls
[i
].idx
> ls
[i
].end
)
2792 ls
[i
].idx
= ls
[i
].start
;
2798 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2808 /* Skip to the end of the current record, taking care of an optional
2809 record marker of size bytes. If the file is not seekable, we
2810 read chunks of size MAX_READ until we get to the right
2814 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2816 ssize_t rlength
, readb
;
2817 static const ssize_t MAX_READ
= 4096;
2820 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2821 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2824 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2826 /* Direct access files do not generate END conditions,
2828 if (sseek (dtp
->u
.p
.current_unit
->s
,
2829 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2830 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2832 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
2835 { /* Seek by reading data. */
2836 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2839 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2840 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2842 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2845 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2849 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2856 /* Advance to the next record reading unformatted files, taking
2857 care of subrecords. If complete_record is nonzero, we loop
2858 until all subrecords are cleared. */
2861 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2865 bytes
= compile_options
.record_marker
== 0 ?
2866 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2871 /* Skip over tail */
2873 skip_record (dtp
, bytes
);
2875 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2883 static inline gfc_offset
2884 min_off (gfc_offset a
, gfc_offset b
)
2886 return (a
< b
? a
: b
);
2890 /* Space to the next record for read mode. */
2893 next_record_r (st_parameter_dt
*dtp
, int done
)
2900 switch (current_mode (dtp
))
2902 /* No records in unformatted STREAM I/O. */
2903 case UNFORMATTED_STREAM
:
2906 case UNFORMATTED_SEQUENTIAL
:
2907 next_record_r_unf (dtp
, 1);
2908 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2911 case FORMATTED_DIRECT
:
2912 case UNFORMATTED_DIRECT
:
2913 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
2916 case FORMATTED_STREAM
:
2917 case FORMATTED_SEQUENTIAL
:
2918 /* read_sf has already terminated input because of an '\n', or
2920 if (dtp
->u
.p
.sf_seen_eor
)
2922 dtp
->u
.p
.sf_seen_eor
= 0;
2926 if (is_internal_unit (dtp
))
2928 if (is_array_io (dtp
))
2932 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2934 if (!done
&& finished
)
2937 /* Now seek to this record. */
2938 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2939 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2941 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2944 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2948 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2949 bytes_left
= min_off (bytes_left
,
2950 file_length (dtp
->u
.p
.current_unit
->s
)
2951 - stell (dtp
->u
.p
.current_unit
->s
));
2952 if (sseek (dtp
->u
.p
.current_unit
->s
,
2953 bytes_left
, SEEK_CUR
) < 0)
2955 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2958 dtp
->u
.p
.current_unit
->bytes_left
2959 = dtp
->u
.p
.current_unit
->recl
;
2968 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2972 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2975 if (is_stream_io (dtp
)
2976 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
2977 || dtp
->u
.p
.current_unit
->bytes_left
2978 == dtp
->u
.p
.current_unit
->recl
)
2984 if (is_stream_io (dtp
))
2985 dtp
->u
.p
.current_unit
->strm_pos
++;
2996 /* Small utility function to write a record marker, taking care of
2997 byte swapping and of choosing the correct size. */
3000 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3005 char p
[sizeof (GFC_INTEGER_8
)];
3007 if (compile_options
.record_marker
== 0)
3008 len
= sizeof (GFC_INTEGER_4
);
3010 len
= compile_options
.record_marker
;
3012 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3013 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3017 case sizeof (GFC_INTEGER_4
):
3019 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3022 case sizeof (GFC_INTEGER_8
):
3024 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3028 runtime_error ("Illegal value for record marker");
3036 case sizeof (GFC_INTEGER_4
):
3038 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
3039 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
3042 case sizeof (GFC_INTEGER_8
):
3044 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
3045 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
3049 runtime_error ("Illegal value for record marker");
3056 /* Position to the next (sub)record in write mode for
3057 unformatted sequential files. */
3060 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3062 gfc_offset m
, m_write
, record_marker
;
3064 /* Bytes written. */
3065 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3066 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3068 /* Write the length tail. If we finish a record containing
3069 subrecords, we write out the negative length. */
3071 if (dtp
->u
.p
.current_unit
->continued
)
3076 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3079 if (compile_options
.record_marker
== 0)
3080 record_marker
= sizeof (GFC_INTEGER_4
);
3082 record_marker
= compile_options
.record_marker
;
3084 /* Seek to the head and overwrite the bogus length with the real
3087 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
3096 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3099 /* Seek past the end of the current record. */
3101 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
3108 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3114 /* Utility function like memset() but operating on streams. Return
3115 value is same as for POSIX write(). */
3118 sset (stream
* s
, int c
, ssize_t nbyte
)
3120 static const int WRITE_CHUNK
= 256;
3121 char p
[WRITE_CHUNK
];
3122 ssize_t bytes_left
, trans
;
3124 if (nbyte
< WRITE_CHUNK
)
3125 memset (p
, c
, nbyte
);
3127 memset (p
, c
, WRITE_CHUNK
);
3130 while (bytes_left
> 0)
3132 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3133 trans
= swrite (s
, p
, trans
);
3136 bytes_left
-= trans
;
3139 return nbyte
- bytes_left
;
3143 memset4 (gfc_char4_t
*p
, gfc_char4_t c
, int k
)
3146 for (j
= 0; j
< k
; j
++)
3150 /* Position to the next record in write mode. */
3153 next_record_w (st_parameter_dt
*dtp
, int done
)
3155 gfc_offset m
, record
, max_pos
;
3158 /* Zero counters for X- and T-editing. */
3159 max_pos
= dtp
->u
.p
.max_pos
;
3160 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3162 switch (current_mode (dtp
))
3164 /* No records in unformatted STREAM I/O. */
3165 case UNFORMATTED_STREAM
:
3168 case FORMATTED_DIRECT
:
3169 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3172 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3173 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3174 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3175 dtp
->u
.p
.current_unit
->bytes_left
)
3176 != dtp
->u
.p
.current_unit
->bytes_left
)
3181 case UNFORMATTED_DIRECT
:
3182 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3184 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3185 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3190 case UNFORMATTED_SEQUENTIAL
:
3191 next_record_w_unf (dtp
, 0);
3192 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3195 case FORMATTED_STREAM
:
3196 case FORMATTED_SEQUENTIAL
:
3198 if (is_internal_unit (dtp
))
3201 if (is_array_io (dtp
))
3205 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3207 /* If the farthest position reached is greater than current
3208 position, adjust the position and set length to pad out
3209 whats left. Otherwise just pad whats left.
3210 (for character array unit) */
3211 m
= dtp
->u
.p
.current_unit
->recl
3212 - dtp
->u
.p
.current_unit
->bytes_left
;
3215 length
= (int) (max_pos
- m
);
3216 if (sseek (dtp
->u
.p
.current_unit
->s
,
3217 length
, SEEK_CUR
) < 0)
3219 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3222 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3225 p
= write_block (dtp
, length
);
3229 if (unlikely (is_char4_unit (dtp
)))
3231 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3232 memset4 (p4
, ' ', length
);
3235 memset (p
, ' ', length
);
3237 /* Now that the current record has been padded out,
3238 determine where the next record in the array is. */
3239 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3242 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3244 /* Now seek to this record */
3245 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3247 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3249 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3253 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3259 /* If this is the last call to next_record move to the farthest
3260 position reached and set length to pad out the remainder
3261 of the record. (for character scaler unit) */
3264 m
= dtp
->u
.p
.current_unit
->recl
3265 - dtp
->u
.p
.current_unit
->bytes_left
;
3268 length
= (int) (max_pos
- m
);
3269 if (sseek (dtp
->u
.p
.current_unit
->s
,
3270 length
, SEEK_CUR
) < 0)
3272 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3275 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3278 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3282 p
= write_block (dtp
, length
);
3286 if (unlikely (is_char4_unit (dtp
)))
3288 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3289 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3292 memset (p
, ' ', length
);
3303 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3304 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3311 if (is_stream_io (dtp
))
3313 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3314 if (dtp
->u
.p
.current_unit
->strm_pos
3315 < file_length (dtp
->u
.p
.current_unit
->s
))
3316 unit_truncate (dtp
->u
.p
.current_unit
,
3317 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3325 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3330 /* Position to the next record, which means moving to the end of the
3331 current record. This can happen under several different
3332 conditions. If the done flag is not set, we get ready to process
3336 next_record (st_parameter_dt
*dtp
, int done
)
3338 gfc_offset fp
; /* File position. */
3340 dtp
->u
.p
.current_unit
->read_bad
= 0;
3342 if (dtp
->u
.p
.mode
== READING
)
3343 next_record_r (dtp
, done
);
3345 next_record_w (dtp
, done
);
3347 if (!is_stream_io (dtp
))
3349 /* Keep position up to date for INQUIRE */
3351 update_position (dtp
->u
.p
.current_unit
);
3353 dtp
->u
.p
.current_unit
->current_record
= 0;
3354 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3356 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3357 /* Calculate next record, rounding up partial records. */
3358 dtp
->u
.p
.current_unit
->last_record
=
3359 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3360 dtp
->u
.p
.current_unit
->recl
;
3363 dtp
->u
.p
.current_unit
->last_record
++;
3369 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3373 /* Finalize the current data transfer. For a nonadvancing transfer,
3374 this means advancing to the next record. For internal units close the
3375 stream associated with the unit. */
3378 finalize_transfer (st_parameter_dt
*dtp
)
3380 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3382 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3383 *dtp
->size
= dtp
->u
.p
.size_used
;
3385 if (dtp
->u
.p
.eor_condition
)
3387 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3391 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3393 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3394 dtp
->u
.p
.current_unit
->current_record
= 0;
3398 if ((dtp
->u
.p
.ionml
!= NULL
)
3399 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3401 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3402 namelist_read (dtp
);
3404 namelist_write (dtp
);
3407 dtp
->u
.p
.transfer
= NULL
;
3408 if (dtp
->u
.p
.current_unit
== NULL
)
3411 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3413 finish_list_read (dtp
);
3417 if (dtp
->u
.p
.mode
== WRITING
)
3418 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3419 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3421 if (is_stream_io (dtp
))
3423 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3424 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3425 next_record (dtp
, 1);
3430 dtp
->u
.p
.current_unit
->current_record
= 0;
3432 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3434 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3435 dtp
->u
.p
.seen_dollar
= 0;
3439 /* For non-advancing I/O, save the current maximum position for use in the
3440 next I/O operation if needed. */
3441 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3443 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3444 - dtp
->u
.p
.current_unit
->bytes_left
);
3445 dtp
->u
.p
.current_unit
->saved_pos
=
3446 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3447 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3450 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3451 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3452 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3454 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3456 next_record (dtp
, 1);
3459 /* Transfer function for IOLENGTH. It doesn't actually do any
3460 data transfer, it just updates the length counter. */
3463 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3464 void *dest
__attribute__ ((unused
)),
3465 int kind
__attribute__((unused
)),
3466 size_t size
, size_t nelems
)
3468 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3469 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3473 /* Initialize the IOLENGTH data transfer. This function is in essence
3474 a very much simplified version of data_transfer_init(), because it
3475 doesn't have to deal with units at all. */
3478 iolength_transfer_init (st_parameter_dt
*dtp
)
3480 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3483 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3485 /* Set up the subroutine that will handle the transfers. */
3487 dtp
->u
.p
.transfer
= iolength_transfer
;
3491 /* Library entry point for the IOLENGTH form of the INQUIRE
3492 statement. The IOLENGTH form requires no I/O to be performed, but
3493 it must still be a runtime library call so that we can determine
3494 the iolength for dynamic arrays and such. */
3496 extern void st_iolength (st_parameter_dt
*);
3497 export_proto(st_iolength
);
3500 st_iolength (st_parameter_dt
*dtp
)
3502 library_start (&dtp
->common
);
3503 iolength_transfer_init (dtp
);
3506 extern void st_iolength_done (st_parameter_dt
*);
3507 export_proto(st_iolength_done
);
3510 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3517 /* The READ statement. */
3519 extern void st_read (st_parameter_dt
*);
3520 export_proto(st_read
);
3523 st_read (st_parameter_dt
*dtp
)
3525 library_start (&dtp
->common
);
3527 data_transfer_init (dtp
, 1);
3530 extern void st_read_done (st_parameter_dt
*);
3531 export_proto(st_read_done
);
3534 st_read_done (st_parameter_dt
*dtp
)
3536 finalize_transfer (dtp
);
3537 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3538 free_format_data (dtp
->u
.p
.fmt
);
3540 if (dtp
->u
.p
.current_unit
!= NULL
)
3541 unlock_unit (dtp
->u
.p
.current_unit
);
3543 free_internal_unit (dtp
);
3548 extern void st_write (st_parameter_dt
*);
3549 export_proto(st_write
);
3552 st_write (st_parameter_dt
*dtp
)
3554 library_start (&dtp
->common
);
3555 data_transfer_init (dtp
, 0);
3558 extern void st_write_done (st_parameter_dt
*);
3559 export_proto(st_write_done
);
3562 st_write_done (st_parameter_dt
*dtp
)
3564 finalize_transfer (dtp
);
3566 /* Deal with endfile conditions associated with sequential files. */
3568 if (dtp
->u
.p
.current_unit
!= NULL
3569 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3570 switch (dtp
->u
.p
.current_unit
->endfile
)
3572 case AT_ENDFILE
: /* Remain at the endfile record. */
3576 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3580 /* Get rid of whatever is after this record. */
3581 if (!is_internal_unit (dtp
))
3582 unit_truncate (dtp
->u
.p
.current_unit
,
3583 stell (dtp
->u
.p
.current_unit
->s
),
3585 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3589 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3590 free_format_data (dtp
->u
.p
.fmt
);
3592 if (dtp
->u
.p
.current_unit
!= NULL
)
3593 unlock_unit (dtp
->u
.p
.current_unit
);
3595 free_internal_unit (dtp
);
3601 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3603 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3608 /* Receives the scalar information for namelist objects and stores it
3609 in a linked list of namelist_info types. */
3611 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3612 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3613 export_proto(st_set_nml_var
);
3617 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3618 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3619 GFC_INTEGER_4 dtype
)
3621 namelist_info
*t1
= NULL
;
3623 size_t var_name_len
= strlen (var_name
);
3625 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3627 nml
->mem_pos
= var_addr
;
3629 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3630 memcpy (nml
->var_name
, var_name
, var_name_len
);
3631 nml
->var_name
[var_name_len
] = '\0';
3633 nml
->len
= (int) len
;
3634 nml
->string_length
= (index_type
) string_length
;
3636 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3637 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3638 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3640 if (nml
->var_rank
> 0)
3642 nml
->dim
= (descriptor_dimension
*)
3643 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3644 nml
->ls
= (array_loop_spec
*)
3645 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3655 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3657 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3658 dtp
->u
.p
.ionml
= nml
;
3662 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3667 /* Store the dimensional information for the namelist object. */
3668 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3669 index_type
, index_type
,
3671 export_proto(st_set_nml_var_dim
);
3674 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3675 index_type stride
, index_type lbound
,
3678 namelist_info
* nml
;
3683 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3685 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3688 /* Reverse memcpy - used for byte swapping. */
3690 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3696 s
= (char *) src
+ n
- 1;
3698 /* Write with ascending order - this is likely faster
3699 on modern architectures because of write combining. */
3705 /* Once upon a time, a poor innocent Fortran program was reading a
3706 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3707 the OS doesn't tell whether we're at the EOF or whether we already
3708 went past it. Luckily our hero, libgfortran, keeps track of this.
3709 Call this function when you detect an EOF condition. See Section
3713 hit_eof (st_parameter_dt
* dtp
)
3715 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3717 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3718 switch (dtp
->u
.p
.current_unit
->endfile
)
3722 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3723 if (!is_internal_unit (dtp
))
3725 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3726 dtp
->u
.p
.current_unit
->current_record
= 0;
3729 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3733 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3734 dtp
->u
.p
.current_unit
->current_record
= 0;
3739 /* Non-sequential files don't have an ENDFILE record, so we
3740 can't be at AFTER_ENDFILE. */
3741 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3742 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3743 dtp
->u
.p
.current_unit
->current_record
= 0;