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)
1051 char buffer[BUFLEN];
1053 if (actual == expected)
1056 /* Adjust item_count before emitting error message. */
1057 snprintf (buffer, BUFLEN,
1058 "Expected %s for item %d in formatted transfer, got %s",
1059 type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
1061 format_error (dtp, f, buffer);
1067 require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
1070 char buffer[BUFLEN];
1072 if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
1075 /* Adjust item_count before emitting error message. */
1076 snprintf (buffer, BUFLEN,
1077 "Expected numeric type for item %d in formatted transfer, got %s",
1078 dtp->u.p.item_count - 1, type_name (actual));
1080 format_error (dtp, f, buffer);
1085 /* This function is in the main loop for a formatted data transfer
1086 statement. It would be natural to implement this as a coroutine
1087 with the user program, but C makes that awkward. We loop,
1088 processing format elements. When we actually have to transfer
1089 data instead of just setting flags, we return control to the user
1090 program which calls a function that supplies the address and type
1091 of the next element, then comes back here to process it. */
1094 formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1097 int pos, bytes_used;
1101 int consume_data_flag;
1103 /* Change a complex data item into a pair of reals. */
1105 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1106 if (type == BT_COMPLEX)
1112 /* If there's an EOR condition, we simulate finalizing the transfer
1113 by doing nothing. */
1114 if (dtp->u.p.eor_condition)
1117 /* Set this flag so that commas in reads cause the read to complete before
1118 the entire field has been read. The next read field will start right after
1119 the comma in the stream. (Set to 0 for character reads). */
1120 dtp->u.p.sf_read_comma =
1121 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1125 /* If reversion has occurred and there is another real data item,
1126 then we have to move to the next record. */
1127 if (dtp->u.p.reversion_flag && n > 0)
1129 dtp->u.p.reversion_flag = 0;
1130 next_record (dtp, 0);
1133 consume_data_flag = 1;
1134 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1137 f = next_format (dtp);
1140 /* No data descriptors left. */
1141 if (unlikely (n > 0))
1142 generate_error (&dtp->common, LIBERROR_FORMAT,
1143 "Insufficient data descriptors in format after reversion");
1149 bytes_used = (int)(dtp->u.p.current_unit->recl
1150 - dtp->u.p.current_unit->bytes_left);
1152 if (is_stream_io(dtp))
1159 goto need_read_data;
1160 if (require_type (dtp, BT_INTEGER, type, f))
1162 read_decimal (dtp, f, p, kind);
1167 goto need_read_data;
1168 if (!(compile_options.allow_std & GFC_STD_GNU)
1169 && require_numeric_type (dtp, type, f))
1171 if (!(compile_options.allow_std & GFC_STD_F2008)
1172 && require_type (dtp, BT_INTEGER, type, f))
1174 read_radix (dtp, f, p, kind, 2);
1179 goto need_read_data;
1180 if (!(compile_options.allow_std & GFC_STD_GNU)
1181 && require_numeric_type (dtp, type, f))
1183 if (!(compile_options.allow_std & GFC_STD_F2008)
1184 && require_type (dtp, BT_INTEGER, type, f))
1186 read_radix (dtp, f, p, kind, 8);
1191 goto need_read_data;
1192 if (!(compile_options.allow_std & GFC_STD_GNU)
1193 && require_numeric_type (dtp, type, f))
1195 if (!(compile_options.allow_std & GFC_STD_F2008)
1196 && require_type (dtp, BT_INTEGER, type, f))
1198 read_radix (dtp, f, p, kind, 16);
1203 goto need_read_data;
1205 /* It is possible to have FMT_A with something not BT_CHARACTER such
1206 as when writing out hollerith strings, so check both type
1207 and kind before calling wide character routines. */
1208 if (type == BT_CHARACTER && kind == 4)
1209 read_a_char4 (dtp, f, p, size);
1211 read_a (dtp, f, p, size);
1216 goto need_read_data;
1217 read_l (dtp, f, p, kind);
1222 goto need_read_data;
1223 if (require_type (dtp, BT_REAL, type, f))
1225 read_f (dtp, f, p, kind);
1230 goto need_read_data;
1231 if (require_type (dtp, BT_REAL, type, f))
1233 read_f (dtp, f, p, kind);
1238 goto need_read_data;
1239 if (require_type (dtp, BT_REAL, type, f))
1241 read_f (dtp, f, p, kind);
1246 goto need_read_data;
1247 if (require_type (dtp, BT_REAL, type, f))
1249 read_f (dtp, f, p, kind);
1254 goto need_read_data;
1255 if (require_type (dtp, BT_REAL, type, f))
1257 read_f (dtp, f, p, kind);
1262 goto need_read_data;
1266 read_decimal (dtp, f, p, kind);
1269 read_l (dtp, f, p, kind);
1273 read_a_char4 (dtp, f, p, size);
1275 read_a (dtp, f, p, size);
1278 read_f (dtp, f, p, kind);
1281 internal_error (&dtp->common, "formatted_transfer(): Bad type");
1286 consume_data_flag = 0;
1287 format_error (dtp, f, "Constant string in input format");
1290 /* Format codes that don't transfer data. */
1293 consume_data_flag = 0;
1294 dtp->u.p.skips += f->u.n;
1295 pos = bytes_used + dtp->u.p.skips - 1;
1296 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1297 read_x (dtp, f->u.n);
1302 consume_data_flag = 0;
1304 if (f->format == FMT_TL)
1306 /* Handle the special case when no bytes have been used yet.
1307 Cannot go below zero. */
1308 if (bytes_used == 0)
1310 dtp->u.p.pending_spaces -= f->u.n;
1311 dtp->u.p.skips -= f->u.n;
1312 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1315 pos = bytes_used - f->u.n;
1320 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1321 left tab limit. We do not check if the position has gone
1322 beyond the end of record because a subsequent tab could
1323 bring us back again. */
1324 pos = pos < 0 ? 0 : pos;
1326 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1327 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1328 + pos - dtp->u.p.max_pos;
1329 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1330 ? 0 : dtp->u.p.pending_spaces;
1331 if (dtp->u.p.skips == 0)
1334 /* Adjust everything for end-of-record condition */
1335 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1337 dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
1338 dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
1340 dtp->u.p.sf_seen_eor = 0;
1342 if (dtp->u.p.skips < 0)
1344 if (is_internal_unit (dtp))
1345 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1347 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1348 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1349 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1352 read_x (dtp, dtp->u.p.skips);
1356 consume_data_flag = 0;
1357 dtp->u.p.sign_status = SIGN_S;
1361 consume_data_flag = 0;
1362 dtp->u.p.sign_status = SIGN_SS;
1366 consume_data_flag = 0;
1367 dtp->u.p.sign_status = SIGN_SP;
1371 consume_data_flag = 0 ;
1372 dtp->u.p.blank_status = BLANK_NULL;
1376 consume_data_flag = 0;
1377 dtp->u.p.blank_status = BLANK_ZERO;
1381 consume_data_flag = 0;
1382 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1386 consume_data_flag = 0;
1387 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1391 consume_data_flag = 0;
1392 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1396 consume_data_flag = 0;
1397 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1401 consume_data_flag = 0;
1402 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1406 consume_data_flag = 0;
1407 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1411 consume_data_flag = 0;
1412 dtp->u.p.current_unit->round_status = ROUND_UP;
1416 consume_data_flag = 0;
1417 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1421 consume_data_flag = 0;
1422 dtp->u.p.scale_factor = f->u.k;
1426 consume_data_flag = 0;
1427 dtp->u.p.seen_dollar = 1;
1431 consume_data_flag = 0;
1432 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1433 next_record (dtp, 0);
1437 /* A colon descriptor causes us to exit this loop (in
1438 particular preventing another / descriptor from being
1439 processed) unless there is another data item to be
1441 consume_data_flag = 0;
1447 internal_error (&dtp->common, "Bad format node");
1450 /* Adjust the item count and data pointer. */
1452 if ((consume_data_flag > 0) && (n > 0))
1455 p = ((char *) p) + size;
1460 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1461 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1466 /* Come here when we need a data descriptor but don't have one. We
1467 push the current format node back onto the input, then return and
1468 let the user program call us back with the data. */
1470 unget_format (dtp, f);
1475 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1478 int pos, bytes_used;
1482 int consume_data_flag;
1484 /* Change a complex data item into a pair of reals. */
1486 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1487 if (type == BT_COMPLEX)
1493 /* If there's an EOR condition, we simulate finalizing the transfer
1494 by doing nothing. */
1495 if (dtp->u.p.eor_condition)
1498 /* Set this flag so that commas in reads cause the read to complete before
1499 the entire field has been read. The next read field will start right after
1500 the comma in the stream. (Set to 0 for character reads). */
1501 dtp->u.p.sf_read_comma =
1502 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
1506 /* If reversion has occurred and there is another real data item,
1507 then we have to move to the next record. */
1508 if (dtp->u.p.reversion_flag && n > 0)
1510 dtp->u.p.reversion_flag = 0;
1511 next_record (dtp, 0);
1514 consume_data_flag = 1;
1515 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1518 f = next_format (dtp);
1521 /* No data descriptors left. */
1522 if (unlikely (n > 0))
1523 generate_error (&dtp->common, LIBERROR_FORMAT,
1524 "Insufficient data descriptors in format after reversion");
1528 /* Now discharge T, TR and X movements to the right. This is delayed
1529 until a data producing format to suppress trailing spaces. */
1532 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
1533 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
1534 || t == FMT_Z || t == FMT_F || t == FMT_E
1535 || t == FMT_EN || t == FMT_ES || t == FMT_G
1536 || t == FMT_L || t == FMT_A || t == FMT_D))
1537 || t == FMT_STRING))
1539 if (dtp->u.p.skips > 0)
1542 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1543 tmp = (int)(dtp->u.p.current_unit->recl
1544 - dtp->u.p.current_unit->bytes_left);
1546 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
1548 if (dtp->u.p.skips < 0)
1550 if (is_internal_unit (dtp))
1551 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
1553 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1554 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1556 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1559 bytes_used = (int)(dtp->u.p.current_unit->recl
1560 - dtp->u.p.current_unit->bytes_left);
1562 if (is_stream_io(dtp))
1570 if (require_type (dtp, BT_INTEGER, type, f))
1572 write_i (dtp, f, p, kind);
1578 if (!(compile_options.allow_std & GFC_STD_GNU)
1579 && require_numeric_type (dtp, type, f))
1581 if (!(compile_options.allow_std & GFC_STD_F2008)
1582 && require_type (dtp, BT_INTEGER, type, f))
1584 write_b (dtp, f, p, kind);
1590 if (!(compile_options.allow_std & GFC_STD_GNU)
1591 && require_numeric_type (dtp, type, f))
1593 if (!(compile_options.allow_std & GFC_STD_F2008)
1594 && require_type (dtp, BT_INTEGER, type, f))
1596 write_o (dtp, f, p, kind);
1602 if (!(compile_options.allow_std & GFC_STD_GNU)
1603 && require_numeric_type (dtp, type, f))
1605 if (!(compile_options.allow_std & GFC_STD_F2008)
1606 && require_type (dtp, BT_INTEGER, type, f))
1608 write_z (dtp, f, p, kind);
1615 /* It is possible to have FMT_A with something not BT_CHARACTER such
1616 as when writing out hollerith strings, so check both type
1617 and kind before calling wide character routines. */
1618 if (type == BT_CHARACTER && kind == 4)
1619 write_a_char4 (dtp, f, p, size);
1621 write_a (dtp, f, p, size);
1627 write_l (dtp, f, p, kind);
1633 if (require_type (dtp, BT_REAL, type, f))
1635 write_d (dtp, f, p, kind);
1641 if (require_type (dtp, BT_REAL, type, f))
1643 write_e (dtp, f, p, kind);
1649 if (require_type (dtp, BT_REAL, type, f))
1651 write_en (dtp, f, p, kind);
1657 if (require_type (dtp, BT_REAL, type, f))
1659 write_es (dtp, f, p, kind);
1665 if (require_type (dtp, BT_REAL, type, f))
1667 write_f (dtp, f, p, kind);
1676 write_i (dtp, f, p, kind);
1679 write_l (dtp, f, p, kind);
1683 write_a_char4 (dtp, f, p, size);
1685 write_a (dtp, f, p, size);
1688 if (f->u.real.w == 0)
1689 write_real_g0 (dtp, p, kind, f->u.real.d);
1691 write_d (dtp, f, p, kind);
1694 internal_error (&dtp->common,
1695 "formatted_transfer(): Bad type");
1700 consume_data_flag = 0;
1701 write_constant_string (dtp, f);
1704 /* Format codes that don't transfer data. */
1707 consume_data_flag = 0;
1709 dtp->u.p.skips += f->u.n;
1710 pos = bytes_used + dtp->u.p.skips - 1;
1711 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1712 /* Writes occur just before the switch on f->format, above, so
1713 that trailing blanks are suppressed, unless we are doing a
1714 non-advancing write in which case we want to output the blanks
1716 if (dtp->u.p.advance_status == ADVANCE_NO)
1718 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1719 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1725 consume_data_flag = 0;
1727 if (f->format == FMT_TL)
1730 /* Handle the special case when no bytes have been used yet.
1731 Cannot go below zero. */
1732 if (bytes_used == 0)
1734 dtp->u.p.pending_spaces -= f->u.n;
1735 dtp->u.p.skips -= f->u.n;
1736 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1739 pos = bytes_used - f->u.n;
1742 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1744 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1745 left tab limit. We do not check if the position has gone
1746 beyond the end of record because a subsequent tab could
1747 bring us back again. */
1748 pos = pos < 0 ? 0 : pos;
1750 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1751 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1752 + pos - dtp->u.p.max_pos;
1753 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1754 ? 0 : dtp->u.p.pending_spaces;
1758 consume_data_flag = 0;
1759 dtp->u.p.sign_status = SIGN_S;
1763 consume_data_flag = 0;
1764 dtp->u.p.sign_status = SIGN_SS;
1768 consume_data_flag = 0;
1769 dtp->u.p.sign_status = SIGN_SP;
1773 consume_data_flag = 0 ;
1774 dtp->u.p.blank_status = BLANK_NULL;
1778 consume_data_flag = 0;
1779 dtp->u.p.blank_status = BLANK_ZERO;
1783 consume_data_flag = 0;
1784 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1788 consume_data_flag = 0;
1789 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1793 consume_data_flag = 0;
1794 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1798 consume_data_flag = 0;
1799 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1803 consume_data_flag = 0;
1804 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1808 consume_data_flag = 0;
1809 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1813 consume_data_flag = 0;
1814 dtp->u.p.current_unit->round_status = ROUND_UP;
1818 consume_data_flag = 0;
1819 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1823 consume_data_flag = 0;
1824 dtp->u.p.scale_factor = f->u.k;
1828 consume_data_flag = 0;
1829 dtp->u.p.seen_dollar = 1;
1833 consume_data_flag = 0;
1834 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1835 next_record (dtp, 0);
1839 /* A colon descriptor causes us to exit this loop (in
1840 particular preventing another / descriptor from being
1841 processed) unless there is another data item to be
1843 consume_data_flag = 0;
1849 internal_error (&dtp->common, "Bad format node");
1852 /* Adjust the item count and data pointer. */
1854 if ((consume_data_flag > 0) && (n > 0))
1857 p = ((char *) p) + size;
1860 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1861 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1866 /* Come here when we need a data descriptor but don't have one. We
1867 push the current format node back onto the input, then return and
1868 let the user program call us back with the data. */
1870 unget_format (dtp, f);
1873 /* This function is first called from data_init_transfer to initiate the loop
1874 over each item in the format, transferring data as required. Subsequent
1875 calls to this function occur for each data item foound in the READ/WRITE
1876 statement. The item_count is incremented for each call. Since the first
1877 call is from data_transfer_init, the item_count is always one greater than
1878 the actual count number of the item being transferred. */
1881 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1882 size_t size, size_t nelems)
1888 size_t stride = type == BT_CHARACTER ?
1889 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1890 if (dtp->u.p.mode == READING)
1892 /* Big loop over all the elements. */
1893 for (elem = 0; elem < nelems; elem++)
1895 dtp->u.p.item_count++;
1896 formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
1901 /* Big loop over all the elements. */
1902 for (elem = 0; elem < nelems; elem++)
1904 dtp->u.p.item_count++;
1905 formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
1911 /* Data transfer entry points. The type of the data entity is
1912 implicit in the subroutine call. This prevents us from having to
1913 share a common enum with the compiler. */
1916 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1918 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1920 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1924 transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
1926 transfer_integer (dtp, p, kind);
1930 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1933 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1935 size = size_from_real_kind (kind);
1936 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1940 transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
1942 transfer_real (dtp, p, kind);
1946 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1948 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1950 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1954 transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
1956 transfer_logical (dtp, p, kind);
1960 transfer_character (st_parameter_dt *dtp, void *p, int len)
1962 static char *empty_string[0];
1964 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1967 /* Strings of zero length can have p == NULL, which confuses the
1968 transfer routines into thinking we need more data elements. To avoid
1969 this, we give them a nice pointer. */
1970 if (len == 0 && p == NULL)
1973 /* Set kind here to 1. */
1974 dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
1978 transfer_character_write (st_parameter_dt *dtp, void *p, int len)
1980 transfer_character (dtp, p, len);
1984 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
1986 static char *empty_string[0];
1988 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1991 /* Strings of zero length can have p == NULL, which confuses the
1992 transfer routines into thinking we need more data elements. To avoid
1993 this, we give them a nice pointer. */
1994 if (len == 0 && p == NULL)
1997 /* Here we pass the actual kind value. */
1998 dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
2002 transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
2004 transfer_character_wide (dtp, p, len, kind);
2008 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
2011 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2013 size = size_from_complex_kind (kind);
2014 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
2018 transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
2020 transfer_complex (dtp, p, kind);
2024 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2025 gfc_charlen_type charlen)
2027 index_type count[GFC_MAX_DIMENSIONS];
2028 index_type extent[GFC_MAX_DIMENSIONS];
2029 index_type stride[GFC_MAX_DIMENSIONS];
2030 index_type stride0, rank, size, n;
2035 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2038 iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
2039 size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
2041 rank = GFC_DESCRIPTOR_RANK (desc);
2042 for (n = 0; n < rank; n++)
2045 stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
2046 extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
2048 /* If the extent of even one dimension is zero, then the entire
2049 array section contains zero elements, so we return after writing
2050 a zero array record. */
2055 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2060 stride0 = stride[0];
2062 /* If the innermost dimension has a stride of 1, we can do the transfer
2063 in contiguous chunks. */
2064 if (stride0 == size)
2069 data = GFC_DESCRIPTOR_DATA (desc);
2073 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2074 data += stride0 * tsize;
2077 while (count[n] == extent[n])
2080 data -= stride[n] * extent[n];
2097 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2098 gfc_charlen_type charlen)
2100 transfer_array (dtp, desc, kind, charlen);
2103 /* Preposition a sequential unformatted file while reading. */
2106 us_read (st_parameter_dt *dtp, int continued)
2113 if (compile_options.record_marker == 0)
2114 n = sizeof (GFC_INTEGER_4);
2116 n = compile_options.record_marker;
2118 nr = sread (dtp->u.p.current_unit->s, &i, n);
2119 if (unlikely (nr < 0))
2121 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2127 return; /* end of file */
2129 else if (unlikely (n != nr))
2131 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2135 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2136 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
2140 case sizeof(GFC_INTEGER_4):
2141 memcpy (&i4, &i, sizeof (i4));
2145 case sizeof(GFC_INTEGER_8):
2146 memcpy (&i8, &i, sizeof (i8));
2151 runtime_error ("Illegal value for record marker");
2158 case sizeof(GFC_INTEGER_4):
2159 reverse_memcpy (&i4, &i, sizeof (i4));
2163 case sizeof(GFC_INTEGER_8):
2164 reverse_memcpy (&i8, &i, sizeof (i8));
2169 runtime_error ("Illegal value for record marker");
2175 dtp->u.p.current_unit->bytes_left_subrecord = i;
2176 dtp->u.p.current_unit->continued = 0;
2180 dtp->u.p.current_unit->bytes_left_subrecord = -i;
2181 dtp->u.p.current_unit->continued = 1;
2185 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2189 /* Preposition a sequential unformatted file while writing. This
2190 amount to writing a bogus length that will be filled in later. */
2193 us_write (st_parameter_dt *dtp, int continued)
2200 if (compile_options.record_marker == 0)
2201 nbytes = sizeof (GFC_INTEGER_4);
2203 nbytes = compile_options.record_marker ;
2205 if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
2206 generate_error (&dtp->common, LIBERROR_OS, NULL);
2208 /* For sequential unformatted, if RECL= was not specified in the OPEN
2209 we write until we have more bytes than can fit in the subrecord
2210 markers, then we write a new subrecord. */
2212 dtp->u.p.current_unit->bytes_left_subrecord =
2213 dtp->u.p.current_unit->recl_subrecord;
2214 dtp->u.p.current_unit->continued = continued;
2218 /* Position to the next record prior to transfer. We are assumed to
2219 be before the next record. We also calculate the bytes in the next
2223 pre_position (st_parameter_dt *dtp)
2225 if (dtp->u.p.current_unit->current_record)
2226 return; /* Already positioned. */
2228 switch (current_mode (dtp))
2230 case FORMATTED_STREAM:
2231 case UNFORMATTED_STREAM:
2232 /* There are no records with stream I/O. If the position was specified
2233 data_transfer_init has already positioned the file. If no position
2234 was specified, we continue from where we last left off. I.e.
2235 there is nothing to do here. */
2238 case UNFORMATTED_SEQUENTIAL:
2239 if (dtp->u.p.mode == READING)
2246 case FORMATTED_SEQUENTIAL:
2247 case FORMATTED_DIRECT:
2248 case UNFORMATTED_DIRECT:
2249 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2253 dtp->u.p.current_unit->current_record = 1;
2257 /* Initialize things for a data transfer. This code is common for
2258 both reading and writing. */
2261 data_transfer_init (st_parameter_dt *dtp, int read_flag)
2263 unit_flags u_flags; /* Used for creating a unit if needed. */
2264 GFC_INTEGER_4 cf = dtp->common.flags;
2265 namelist_info *ionml;
2267 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
2269 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2271 dtp->u.p.ionml = ionml;
2272 dtp->u.p.mode = read_flag ? READING : WRITING;
2274 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2277 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2278 dtp->u.p.size_used = 0; /* Initialize the count. */
2280 dtp->u.p.current_unit = get_unit (dtp, 1);
2281 if (dtp->u.p.current_unit->s == NULL)
2282 { /* Open the unit with some default flags. */
2283 st_parameter_open opp;
2286 if (dtp->common.unit < 0)
2288 close_unit (dtp->u.p.current_unit);
2289 dtp->u.p.current_unit = NULL;
2290 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2291 "Bad unit number in statement");
2294 memset (&u_flags, '\0', sizeof (u_flags));
2295 u_flags.access = ACCESS_SEQUENTIAL;
2296 u_flags.action = ACTION_READWRITE;
2298 /* Is it unformatted? */
2299 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
2300 | IOPARM_DT_IONML_SET)))
2301 u_flags.form = FORM_UNFORMATTED;
2303 u_flags.form = FORM_UNSPECIFIED;
2305 u_flags.delim = DELIM_UNSPECIFIED;
2306 u_flags.blank = BLANK_UNSPECIFIED;
2307 u_flags.pad = PAD_UNSPECIFIED;
2308 u_flags.decimal = DECIMAL_UNSPECIFIED;
2309 u_flags.encoding = ENCODING_UNSPECIFIED;
2310 u_flags.async = ASYNC_UNSPECIFIED;
2311 u_flags.round = ROUND_UNSPECIFIED;
2312 u_flags.sign = SIGN_UNSPECIFIED;
2314 u_flags.status = STATUS_UNKNOWN;
2316 conv = get_unformatted_convert (dtp->common.unit);
2318 if (conv == GFC_CONVERT_NONE)
2319 conv = compile_options.convert;
2321 /* We use big_endian, which is 0 on little-endian machines
2322 and 1 on big-endian machines. */
2325 case GFC_CONVERT_NATIVE:
2326 case GFC_CONVERT_SWAP:
2329 case GFC_CONVERT_BIG:
2330 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
2333 case GFC_CONVERT_LITTLE:
2334 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
2338 internal_error (&opp.common, "Illegal value for CONVERT");
2342 u_flags.convert = conv;
2344 opp.common = dtp->common;
2345 opp.common.flags &= IOPARM_COMMON_MASK;
2346 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
2347 dtp->common.flags &= ~IOPARM_COMMON_MASK;
2348 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
2349 if (dtp->u.p.current_unit == NULL)
2353 /* Check the action. */
2355 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
2357 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2358 "Cannot read from file opened for WRITE");
2362 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
2364 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
2365 "Cannot write to file opened for READ");
2369 dtp->u.p.first_item = 1;
2371 /* Check the format. */
2373 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2376 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2377 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2380 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2381 "Format present for UNFORMATTED data transfer");
2385 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
2387 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2388 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2389 "A format cannot be specified with a namelist");
2391 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
2392 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
2394 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2395 "Missing format for FORMATTED data transfer");
2398 if (is_internal_unit (dtp)
2399 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2401 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2402 "Internal file cannot be accessed by UNFORMATTED "
2407 /* Check the record or position number. */
2409 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
2410 && (cf & IOPARM_DT_HAS_REC) == 0)
2412 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2413 "Direct access data transfer requires record number");
2417 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2419 if ((cf & IOPARM_DT_HAS_REC) != 0)
2421 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2422 "Record number not allowed for sequential access "
2427 if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
2429 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2430 "Sequential READ or WRITE not allowed after "
2431 "EOF marker, possibly use REWIND or BACKSPACE");
2436 /* Process the ADVANCE option. */
2438 dtp->u.p.advance_status
2439 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
2440 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
2441 "Bad ADVANCE parameter in data transfer statement");
2443 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
2445 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2447 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2448 "ADVANCE specification conflicts with sequential "
2453 if (is_internal_unit (dtp))
2455 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2456 "ADVANCE specification conflicts with internal file");
2460 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2461 != IOPARM_DT_HAS_FORMAT)
2463 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2464 "ADVANCE specification requires an explicit format");
2471 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
2473 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
2475 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2476 "EOR specification requires an ADVANCE specification "
2481 if ((cf & IOPARM_DT_HAS_SIZE) != 0
2482 && dtp->u.p.advance_status != ADVANCE_NO)
2484 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2485 "SIZE specification requires an ADVANCE "
2486 "specification of NO");
2491 { /* Write constraints. */
2492 if ((cf & IOPARM_END) != 0)
2494 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2495 "END specification cannot appear in a write "
2500 if ((cf & IOPARM_EOR) != 0)
2502 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2503 "EOR specification cannot appear in a write "
2508 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2510 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2511 "SIZE specification cannot appear in a write "
2517 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
2518 dtp->u.p.advance_status = ADVANCE_YES;
2520 /* Check the decimal mode. */
2521 dtp->u.p.current_unit->decimal_status
2522 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
2523 find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
2524 decimal_opt, "Bad DECIMAL parameter in data transfer "
2527 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
2528 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
2530 /* Check the round mode. */
2531 dtp->u.p.current_unit->round_status
2532 = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
2533 find_option (&dtp->common, dtp->round, dtp->round_len,
2534 round_opt, "Bad ROUND parameter in data transfer "
2537 if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
2538 dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
2540 /* Check the sign mode. */
2541 dtp->u.p.sign_status
2542 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
2543 find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
2544 "Bad SIGN parameter in data transfer statement");
2546 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
2547 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
2549 /* Check the blank mode. */
2550 dtp->u.p.blank_status
2551 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
2552 find_option (&dtp->common, dtp->blank, dtp->blank_len,
2554 "Bad BLANK parameter in data transfer statement");
2556 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
2557 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2559 /* Check the delim mode. */
2560 dtp->u.p.current_unit->delim_status
2561 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
2562 find_option (&dtp->common, dtp->delim, dtp->delim_len,
2563 delim_opt, "Bad DELIM parameter in data transfer statement");
2565 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
2566 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
2568 /* Check the pad mode. */
2569 dtp->u.p.current_unit->pad_status
2570 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
2571 find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
2572 "Bad PAD parameter in data transfer statement");
2574 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
2575 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
2577 /* Check to see if we might be reading what we wrote before */
2579 if (dtp->u.p.mode != dtp->u.p.current_unit->mode
2580 && !is_internal_unit (dtp))
2582 int pos = fbuf_reset (dtp->u.p.current_unit);
2584 sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
2585 sflush(dtp->u.p.current_unit->s);
2588 /* Check the POS= specifier: that it is in range and that it is used with a
2589 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2591 if (((cf & IOPARM_DT_HAS_POS) != 0))
2593 if (is_stream_io (dtp))
2598 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2599 "POS=specifier must be positive");
2603 if (dtp->pos >= dtp->u.p.current_unit->maxrec)
2605 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2606 "POS=specifier too large");
2610 dtp->rec = dtp->pos;
2612 if (dtp->u.p.mode == READING)
2614 /* Reset the endfile flag; if we hit EOF during reading
2615 we'll set the flag and generate an error at that point
2616 rather than worrying about it here. */
2617 dtp->u.p.current_unit->endfile = NO_ENDFILE;
2620 if (dtp->pos != dtp->u.p.current_unit->strm_pos)
2622 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
2623 if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
2625 generate_error (&dtp->common, LIBERROR_OS, NULL);
2628 dtp->u.p.current_unit->strm_pos = dtp->pos;
2633 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2634 "POS=specifier not allowed, "
2635 "Try OPEN with ACCESS='stream'");
2641 /* Sanity checks on the record number. */
2642 if ((cf & IOPARM_DT_HAS_REC) != 0)
2646 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2647 "Record number must be positive");
2651 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
2653 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2654 "Record number too large");
2658 /* Make sure format buffer is reset. */
2659 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2660 fbuf_reset (dtp->u.p.current_unit);
2663 /* Check whether the record exists to be read. Only
2664 a partial record needs to exist. */
2666 if (dtp->u.p.mode == READING && (dtp->rec - 1)
2667 * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
2669 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2670 "Non-existing record number");
2674 /* Position the file. */
2675 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
2676 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
2678 generate_error (&dtp->common, LIBERROR_OS, NULL);
2682 /* TODO: This is required to maintain compatibility between
2683 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2685 if (is_stream_io (dtp))
2686 dtp->u.p.current_unit->strm_pos = dtp->rec;
2688 /* TODO: Un-comment this code when ABI changes from 4.3.
2689 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2691 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2692 "Record number not allowed for stream access "
2698 /* Bugware for badly written mixed C-Fortran I/O. */
2699 if (!is_internal_unit (dtp))
2700 flush_if_preconnected(dtp->u.p.current_unit->s);
2702 dtp->u.p.current_unit->mode = dtp->u.p.mode;
2704 /* Set the maximum position reached from the previous I/O operation. This
2705 could be greater than zero from a previous non-advancing write. */
2706 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2711 /* Set up the subroutine that will handle the transfers. */
2715 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2716 dtp->u.p.transfer = unformatted_read;
2719 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2721 dtp->u.p.last_char = EOF - 1;
2722 dtp->u.p.transfer = list_formatted_read;
2725 dtp->u.p.transfer = formatted_transfer;
2730 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2731 dtp->u.p.transfer = unformatted_write;
2734 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2735 dtp->u.p.transfer = list_formatted_write;
2737 dtp->u.p.transfer = formatted_transfer;
2741 /* Make sure that we don't do a read after a nonadvancing write. */
2745 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2747 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2748 "Cannot READ after a nonadvancing WRITE");
2754 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2755 dtp->u.p.current_unit->read_bad = 1;
2758 /* Start the data transfer if we are doing a formatted transfer. */
2759 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2760 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2761 && dtp->u.p.ionml == NULL)
2762 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2765 /* Initialize an array_loop_spec given the array descriptor. The function
2766 returns the index of the last element of the array, and also returns
2767 starting record, where the first I/O goes to (necessary in case of
2768 negative strides). */
2771 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2772 gfc_offset *start_record)
2774 int rank = GFC_DESCRIPTOR_RANK(desc);
2783 for (i=0; i<rank; i++)
2785 ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
2786 ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
2787 ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
2788 ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
2789 empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
2790 < GFC_DESCRIPTOR_LBOUND(desc,i));
2792 if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
2794 index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2795 * GFC_DESCRIPTOR_STRIDE(desc,i);
2799 index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2800 * GFC_DESCRIPTOR_STRIDE(desc,i);
2801 *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
2802 * GFC_DESCRIPTOR_STRIDE(desc,i);
2812 /* Determine the index to the next record in an internal unit array by
2813 by incrementing through the array_loop_spec. */
2816 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2824 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2829 if (ls[i].idx > ls[i].end)
2831 ls[i].idx = ls[i].start;
2837 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2847 /* Skip to the end of the current record, taking care of an optional
2848 record marker of size bytes. If the file is not seekable, we
2849 read chunks of size MAX_READ until we get to the right
2853 skip_record (st_parameter_dt *dtp, ssize_t bytes)
2855 ssize_t rlength, readb;
2856 static const ssize_t MAX_READ = 4096;
2859 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2860 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2863 /* Direct access files do not generate END conditions,
2865 if (sseek (dtp->u.p.current_unit->s,
2866 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
2868 /* Seeking failed, fall back to seeking by reading data. */
2869 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2872 (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
2873 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2875 readb = sread (dtp->u.p.current_unit->s, p, rlength);
2878 generate_error (&dtp->common, LIBERROR_OS, NULL);
2882 dtp->u.p.current_unit->bytes_left_subrecord -= readb;
2886 dtp->u.p.current_unit->bytes_left_subrecord = 0;
2890 /* Advance to the next record reading unformatted files, taking
2891 care of subrecords. If complete_record is nonzero, we loop
2892 until all subrecords are cleared. */
2895 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2899 bytes = compile_options.record_marker == 0 ?
2900 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2905 /* Skip over tail */
2907 skip_record (dtp, bytes);
2909 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2918 min_off (gfc_offset a, gfc_offset b)
2920 return (a < b ? a : b);
2924 /* Space to the next record for read mode. */
2927 next_record_r (st_parameter_dt *dtp, int done)
2934 switch (current_mode (dtp))
2936 /* No records in unformatted STREAM I/O. */
2937 case UNFORMATTED_STREAM:
2940 case UNFORMATTED_SEQUENTIAL:
2941 next_record_r_unf (dtp, 1);
2942 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2945 case FORMATTED_DIRECT:
2946 case UNFORMATTED_DIRECT:
2947 skip_record (dtp, dtp->u.p.current_unit->bytes_left);
2950 case FORMATTED_STREAM:
2951 case FORMATTED_SEQUENTIAL:
2952 /* read_sf has already terminated input because of an '\n', or
2954 if (dtp->u.p.sf_seen_eor)
2956 dtp->u.p.sf_seen_eor = 0;
2960 if (is_internal_unit (dtp))
2962 if (is_array_io (dtp))
2966 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2968 if (!done && finished)
2971 /* Now seek to this record. */
2972 record = record * dtp->u.p.current_unit->recl;
2973 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
2975 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2978 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2982 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2983 bytes_left = min_off (bytes_left,
2984 ssize (dtp->u.p.current_unit->s)
2985 - stell (dtp->u.p.current_unit->s));
2986 if (sseek (dtp->u.p.current_unit->s,
2987 bytes_left, SEEK_CUR) < 0)
2989 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2992 dtp->u.p.current_unit->bytes_left
2993 = dtp->u.p.current_unit->recl;
3002 cc = fbuf_getc (dtp->u.p.current_unit);
3006 generate_error (&dtp->common, LIBERROR_OS, NULL);
3009 if (is_stream_io (dtp)
3010 || dtp->u.p.current_unit->pad_status == PAD_NO
3011 || dtp->u.p.current_unit->bytes_left
3012 == dtp->u.p.current_unit->recl)
3018 if (is_stream_io (dtp))
3019 dtp->u.p.current_unit->strm_pos++;
3030 /* Small utility function to write a record marker, taking care of
3031 byte swapping and of choosing the correct size. */
3034 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
3039 char p[sizeof (GFC_INTEGER_8)];
3041 if (compile_options.record_marker == 0)
3042 len = sizeof (GFC_INTEGER_4);
3044 len = compile_options.record_marker;
3046 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3047 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
3051 case sizeof (GFC_INTEGER_4):
3053 return swrite (dtp->u.p.current_unit->s, &buf4, len);
3056 case sizeof (GFC_INTEGER_8):
3058 return swrite (dtp->u.p.current_unit->s, &buf8, len);
3062 runtime_error ("Illegal value for record marker");
3070 case sizeof (GFC_INTEGER_4):
3072 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
3073 return swrite (dtp->u.p.current_unit->s, p, len);
3076 case sizeof (GFC_INTEGER_8):
3078 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
3079 return swrite (dtp->u.p.current_unit->s, p, len);
3083 runtime_error ("Illegal value for record marker");
3090 /* Position to the next (sub)record in write mode for
3091 unformatted sequential files. */
3094 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
3096 gfc_offset m, m_write, record_marker;
3098 /* Bytes written. */
3099 m = dtp->u.p.current_unit->recl_subrecord
3100 - dtp->u.p.current_unit->bytes_left_subrecord;
3102 /* Write the length tail. If we finish a record containing
3103 subrecords, we write out the negative length. */
3105 if (dtp->u.p.current_unit->continued)
3110 if (unlikely (write_us_marker (dtp, m_write) < 0))
3113 if (compile_options.record_marker == 0)
3114 record_marker = sizeof (GFC_INTEGER_4);
3116 record_marker = compile_options.record_marker;
3118 /* Seek to the head and overwrite the bogus length with the real
3121 if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker,
3130 if (unlikely (write_us_marker (dtp, m_write) < 0))
3133 /* Seek past the end of the current record. */
3135 if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker,
3142 generate_error (&dtp->common, LIBERROR_OS, NULL);
3148 /* Utility function like memset() but operating on streams. Return
3149 value is same as for POSIX write(). */
3152 sset (stream * s, int c, ssize_t nbyte)
3154 static const int WRITE_CHUNK = 256;
3155 char p[WRITE_CHUNK];
3156 ssize_t bytes_left, trans;
3158 if (nbyte < WRITE_CHUNK)
3159 memset (p, c, nbyte);
3161 memset (p, c, WRITE_CHUNK);
3164 while (bytes_left > 0)
3166 trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
3167 trans = swrite (s, p, trans);
3170 bytes_left -= trans;
3173 return nbyte - bytes_left;
3177 /* Position to the next record in write mode. */
3180 next_record_w (st_parameter_dt *dtp, int done)
3182 gfc_offset m, record, max_pos;
3185 /* Zero counters for X- and T-editing. */
3186 max_pos = dtp->u.p.max_pos;
3187 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
3189 switch (current_mode (dtp))
3191 /* No records in unformatted STREAM I/O. */
3192 case UNFORMATTED_STREAM:
3195 case FORMATTED_DIRECT:
3196 if (dtp->u.p.current_unit->bytes_left == 0)
3199 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3200 fbuf_flush (dtp->u.p.current_unit, WRITING);
3201 if (sset (dtp->u.p.current_unit->s, ' ',
3202 dtp->u.p.current_unit->bytes_left)
3203 != dtp->u.p.current_unit->bytes_left)
3208 case UNFORMATTED_DIRECT:
3209 if (dtp->u.p.current_unit->bytes_left > 0)
3211 length = (int) dtp->u.p.current_unit->bytes_left;
3212 if (sset (dtp->u.p.current_unit->s, 0, length) != length)
3217 case UNFORMATTED_SEQUENTIAL:
3218 next_record_w_unf (dtp, 0);
3219 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3222 case FORMATTED_STREAM:
3223 case FORMATTED_SEQUENTIAL:
3225 if (is_internal_unit (dtp))
3228 if (is_array_io (dtp))
3232 length = (int) dtp->u.p.current_unit->bytes_left;
3234 /* If the farthest position reached is greater than current
3235 position, adjust the position and set length to pad out
3236 whats left. Otherwise just pad whats left.
3237 (for character array unit) */
3238 m = dtp->u.p.current_unit->recl
3239 - dtp->u.p.current_unit->bytes_left;
3242 length = (int) (max_pos - m);
3243 if (sseek (dtp->u.p.current_unit->s,
3244 length, SEEK_CUR) < 0)
3246 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3249 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3252 p = write_block (dtp, length);
3256 if (unlikely (is_char4_unit (dtp)))
3258 gfc_char4_t *p4 = (gfc_char4_t *) p;
3259 memset4 (p4, ' ', length);
3262 memset (p, ' ', length);
3264 /* Now that the current record has been padded out,
3265 determine where the next record in the array is. */
3266 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3269 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3271 /* Now seek to this record */
3272 record = record * dtp->u.p.current_unit->recl;
3274 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
3276 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3280 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3286 /* If this is the last call to next_record move to the farthest
3287 position reached and set length to pad out the remainder
3288 of the record. (for character scaler unit) */
3291 m = dtp->u.p.current_unit->recl
3292 - dtp->u.p.current_unit->bytes_left;
3295 length = (int) (max_pos - m);
3296 if (sseek (dtp->u.p.current_unit->s,
3297 length, SEEK_CUR) < 0)
3299 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3302 length = (int) (dtp->u.p.current_unit->recl - max_pos);
3305 length = (int) dtp->u.p.current_unit->bytes_left;
3309 p = write_block (dtp, length);
3313 if (unlikely (is_char4_unit (dtp)))
3315 gfc_char4_t *p4 = (gfc_char4_t *) p;
3316 memset4 (p4, (gfc_char4_t) ' ', length);
3319 memset (p, ' ', length);
3330 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3331 char * p = fbuf_alloc (dtp->u.p.current_unit, len);
3338 if (is_stream_io (dtp))
3340 dtp->u.p.current_unit->strm_pos += len;
3341 if (dtp->u.p.current_unit->strm_pos
3342 < ssize (dtp->u.p.current_unit->s))
3343 unit_truncate (dtp->u.p.current_unit,
3344 dtp->u.p.current_unit->strm_pos - 1,
3352 generate_error (&dtp->common, LIBERROR_OS, NULL);
3357 /* Position to the next record, which means moving to the end of the
3358 current record. This can happen under several different
3359 conditions. If the done flag is not set, we get ready to process
3363 next_record (st_parameter_dt *dtp, int done)
3365 gfc_offset fp; /* File position. */
3367 dtp->u.p.current_unit->read_bad = 0;
3369 if (dtp->u.p.mode == READING)
3370 next_record_r (dtp, done);
3372 next_record_w (dtp, done);
3374 if (!is_stream_io (dtp))
3376 /* Since we have changed the position, set it to unspecified so
3377 that INQUIRE(POSITION=) knows it needs to look into it. */
3379 dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
3381 dtp->u.p.current_unit->current_record = 0;
3382 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
3384 fp = stell (dtp->u.p.current_unit->s);
3385 /* Calculate next record, rounding up partial records. */
3386 dtp->u.p.current_unit->last_record =
3387 (fp + dtp->u.p.current_unit->recl - 1) /
3388 dtp->u.p.current_unit->recl;
3391 dtp->u.p.current_unit->last_record++;
3397 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3401 /* Finalize the current data transfer. For a nonadvancing transfer,
3402 this means advancing to the next record. For internal units close the
3403 stream associated with the unit. */
3406 finalize_transfer (st_parameter_dt *dtp)
3408 GFC_INTEGER_4 cf = dtp->common.flags;
3410 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
3411 *dtp->size = dtp->u.p.size_used;
3413 if (dtp->u.p.eor_condition)
3415 generate_error (&dtp->common, LIBERROR_EOR, NULL);
3419 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
3421 if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
3422 dtp->u.p.current_unit->current_record = 0;
3426 if ((dtp->u.p.ionml != NULL)
3427 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
3429 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
3430 namelist_read (dtp);
3432 namelist_write (dtp);
3435 dtp->u.p.transfer = NULL;
3436 if (dtp->u.p.current_unit == NULL)
3439 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
3441 finish_list_read (dtp);
3445 if (dtp->u.p.mode == WRITING)
3446 dtp->u.p.current_unit->previous_nonadvancing_write
3447 = dtp->u.p.advance_status == ADVANCE_NO;
3449 if (is_stream_io (dtp))
3451 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3452 && dtp->u.p.advance_status != ADVANCE_NO)
3453 next_record (dtp, 1);
3458 dtp->u.p.current_unit->current_record = 0;
3460 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
3462 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3463 dtp->u.p.seen_dollar = 0;
3467 /* For non-advancing I/O, save the current maximum position for use in the
3468 next I/O operation if needed. */
3469 if (dtp->u.p.advance_status == ADVANCE_NO)
3471 int bytes_written = (int) (dtp->u.p.current_unit->recl
3472 - dtp->u.p.current_unit->bytes_left);
3473 dtp->u.p.current_unit->saved_pos =
3474 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
3475 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
3478 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
3479 && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
3480 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3482 dtp->u.p.current_unit->saved_pos = 0;
3484 next_record (dtp, 1);
3487 /* Transfer function for IOLENGTH. It doesn't actually do any
3488 data transfer, it just updates the length counter. */
3491 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
3492 void *dest __attribute__ ((unused)),
3493 int kind __attribute__((unused)),
3494 size_t size, size_t nelems)
3496 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3497 *dtp->iolength += (GFC_IO_INT) (size * nelems);
3501 /* Initialize the IOLENGTH data transfer. This function is in essence
3502 a very much simplified version of data_transfer_init(), because it
3503 doesn't have to deal with units at all. */
3506 iolength_transfer_init (st_parameter_dt *dtp)
3508 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
3511 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
3513 /* Set up the subroutine that will handle the transfers. */
3515 dtp->u.p.transfer = iolength_transfer;
3519 /* Library entry point for the IOLENGTH form of the INQUIRE
3520 statement. The IOLENGTH form requires no I/O to be performed, but
3521 it must still be a runtime library call so that we can determine
3522 the iolength for dynamic arrays and such. */
3524 extern void st_iolength (st_parameter_dt *);
3525 export_proto(st_iolength);
3528 st_iolength (st_parameter_dt *dtp)
3530 library_start (&dtp->common);
3531 iolength_transfer_init (dtp);
3534 extern void st_iolength_done (st_parameter_dt *);
3535 export_proto(st_iolength_done);
3538 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
3545 /* The READ statement. */
3547 extern void st_read (st_parameter_dt *);
3548 export_proto(st_read);
3551 st_read (st_parameter_dt *dtp)
3553 library_start (&dtp->common);
3555 data_transfer_init (dtp, 1);
3558 extern void st_read_done (st_parameter_dt *);
3559 export_proto(st_read_done);
3562 st_read_done (st_parameter_dt *dtp)
3564 finalize_transfer (dtp);
3565 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3566 free_format_data (dtp->u.p.fmt);
3568 if (dtp->u.p.current_unit != NULL)
3569 unlock_unit (dtp->u.p.current_unit);
3571 free_internal_unit (dtp);
3576 extern void st_write (st_parameter_dt *);
3577 export_proto(st_write);
3580 st_write (st_parameter_dt *dtp)
3582 library_start (&dtp->common);
3583 data_transfer_init (dtp, 0);
3586 extern void st_write_done (st_parameter_dt *);
3587 export_proto(st_write_done);
3590 st_write_done (st_parameter_dt *dtp)
3592 finalize_transfer (dtp);
3594 /* Deal with endfile conditions associated with sequential files. */
3596 if (dtp->u.p.current_unit != NULL
3597 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3598 switch (dtp->u.p.current_unit->endfile)
3600 case AT_ENDFILE: /* Remain at the endfile record. */
3604 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
3608 /* Get rid of whatever is after this record. */
3609 if (!is_internal_unit (dtp))
3610 unit_truncate (dtp->u.p.current_unit,
3611 stell (dtp->u.p.current_unit->s),
3613 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3617 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
3618 free_format_data (dtp->u.p.fmt);
3620 if (dtp->u.p.current_unit != NULL)
3621 unlock_unit (dtp->u.p.current_unit);
3623 free_internal_unit (dtp);
3629 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3631 st_wait (st_parameter_wait *wtp __attribute__((unused)))
3636 /* Receives the scalar information for namelist objects and stores it
3637 in a linked list of namelist_info types. */
3639 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
3640 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
3641 export_proto(st_set_nml_var);
3645 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
3646 GFC_INTEGER_4 len, gfc_charlen_type string_length,
3647 GFC_INTEGER_4 dtype)
3649 namelist_info *t1 = NULL;
3651 size_t var_name_len = strlen (var_name);
3653 nml = (namelist_info*) get_mem (sizeof (namelist_info));
3655 nml->mem_pos = var_addr;
3657 nml->var_name = (char*) get_mem (var_name_len + 1);
3658 memcpy (nml->var_name, var_name, var_name_len);
3659 nml->var_name[var_name_len] = '\0';
3661 nml->len = (int) len;
3662 nml->string_length = (index_type) string_length;
3664 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
3665 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
3666 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
3668 if (nml->var_rank > 0)
3670 nml->dim = (descriptor_dimension*)
3671 get_mem (nml->var_rank * sizeof (descriptor_dimension));
3672 nml->ls = (array_loop_spec*)
3673 get_mem (nml->var_rank * sizeof (array_loop_spec));
3683 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
3685 dtp->common.flags |= IOPARM_DT_IONML_SET;
3686 dtp->u.p.ionml = nml;
3690 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
3695 /* Store the dimensional information for the namelist object. */
3696 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
3697 index_type, index_type,
3699 export_proto(st_set_nml_var_dim);
3702 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
3703 index_type stride, index_type lbound,
3706 namelist_info * nml;
3711 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
3713 GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
3716 /* Reverse memcpy - used for byte swapping. */
3718 void reverse_memcpy (void *dest, const void *src, size_t n)
3724 s = (char *) src + n - 1;
3726 /* Write with ascending order - this is likely faster
3727 on modern architectures because of write combining. */
3733 /* Once upon a time, a poor innocent Fortran program was reading a
3734 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3735 the OS doesn't tell whether we're at the EOF or whether we already
3736 went past it. Luckily our hero, libgfortran, keeps track of this.
3737 Call this function when you detect an EOF condition. See Section
3741 hit_eof (st_parameter_dt * dtp)
3743 dtp->u.p.current_unit->flags.position = POSITION_APPEND;
3745 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3746 switch (dtp->u.p.current_unit->endfile)
3750 generate_error (&dtp->common, LIBERROR_END, NULL);
3751 if (!is_internal_unit (dtp))
3753 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
3754 dtp->u.p.current_unit->current_record = 0;
3757 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3761 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
3762 dtp->u.p.current_unit->current_record = 0;
3767 /* Non-sequential files don't have an ENDFILE record, so we
3768 can't be at AFTER_ENDFILE. */
3769 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3770 generate_error (&dtp->common, LIBERROR_END, NULL);
3771 dtp->u.p.current_unit->current_record = 0;