diff options
Diffstat (limited to 'libgfortran/io/transfer.c')
| -rw-r--r-- | libgfortran/io/transfer.c | 1285 |
1 files changed, 742 insertions, 543 deletions
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 4d314c5939d..cf25a89fff6 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -32,6 +32,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include <string.h> #include <assert.h> #include <stdlib.h> +#include <errno.h> /* Calling conventions: Data transfer statements are unlike other @@ -178,60 +179,58 @@ current_mode (st_parameter_dt *dtp) heap. Hopefully this won't happen very often. */ char * -read_sf (st_parameter_dt *dtp, int *length, int no_error) +read_sf (st_parameter_dt *dtp, int * length, int no_error) { + static char *empty_string[0]; char *base, *p, q; - int n, crlf; - gfc_offset pos; - size_t readlen; + int n, lorig, memread, seen_comma; - if (*length > SCRATCH_SIZE) - dtp->u.p.line_buffer = get_mem (*length); - p = base = dtp->u.p.line_buffer; + /* If we hit EOF previously with the no_error flag set (i.e. X, T, + TR edit descriptors), and we now try to read again, this time + without setting no_error. */ + if (!no_error && dtp->u.p.at_eof) + { + *length = 0; + hit_eof (dtp); + return NULL; + } /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ if (dtp->u.p.sf_seen_eor) { *length = 0; - return base; + /* Just return something that isn't a NULL pointer, otherwise the + caller thinks an error occured. */ + return (char*) empty_string; } if (is_internal_unit (dtp)) { - readlen = *length; - if (unlikely (sread (dtp->u.p.current_unit->s, p, &readlen) != 0 - || readlen < (size_t) *length)) + memread = *length; + base = mem_alloc_r (dtp->u.p.current_unit->s, length); + if (unlikely (memread > *length)) { - generate_error (&dtp->common, LIBERROR_END, NULL); + hit_eof (dtp); return NULL; } - + n = *length; goto done; } - readlen = 1; - n = 0; + n = seen_comma = 0; - do - { - if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } + /* Read data into format buffer and scan through it. */ + lorig = *length; + base = p = fbuf_read (dtp->u.p.current_unit, length); + if (base == NULL) + return NULL; - /* If we have a line without a terminating \n, drop through to - EOR below. */ - if (readlen < 1 && n == 0) - { - if (likely (no_error)) - break; - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } + while (n < *length) + { + q = *p; - if (readlen < 1 || q == '\n' || q == '\r') + if (q == '\n' || q == '\r') { /* Unexpected end of line. */ @@ -240,23 +239,14 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; - crlf = 0; /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { - readlen = 1; - pos = stream_offset (dtp->u.p.current_unit->s); - if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) - != 0)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return NULL; - } - if (q != '\n' && readlen == 1) /* Not a CRLF after all. */ - sseek (dtp->u.p.current_unit->s, pos); - else - crlf = 1; + if (n < *length && *(p + 1) == '\n') + dtp->u.p.sf_seen_eor = 2; } + else + dtp->u.p.sf_seen_eor = 1; /* Without padding, terminate the I/O statement without assigning the value. With padding, the value still needs to be assigned, @@ -270,7 +260,6 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) } *length = n; - dtp->u.p.sf_seen_eor = (crlf ? 2 : 1); break; } /* Short circuit the read if a comma is found during numeric input. @@ -279,6 +268,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) if (q == ',') if (dtp->u.p.sf_read_comma == 1) { + seen_comma = 1; notify_std (&dtp->common, GFC_STD_GNU, "Comma in formatted numeric read."); *length = n; @@ -286,16 +276,31 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) } n++; - *p++ = q; - dtp->u.p.sf_seen_eor = 0; + p++; + } + + fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + seen_comma, + SEEK_CUR); + + /* A short read implies we hit EOF, unless we hit EOR, a comma, or + some other stuff. Set the relevant flags. */ + if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma) + { + if (no_error) + dtp->u.p.at_eof = 1; + else + { + hit_eof (dtp); + return NULL; + } } - while (n < *length); done: - dtp->u.p.current_unit->bytes_left -= *length; + + dtp->u.p.current_unit->bytes_left -= n; if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) *length; + dtp->u.p.size_used += (GFC_IO_INT) n; return base; } @@ -311,12 +316,11 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error) opened with PAD=YES. The caller must assume tailing spaces for short reads. */ -try -read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) +void * +read_block_form (st_parameter_dt *dtp, int * nbytes) { char *source; - size_t nread; - int nb; + int norig; if (!is_stream_io (dtp)) { @@ -333,15 +337,14 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) { /* Not enough data left. */ generate_error (&dtp->common, LIBERROR_EOR, NULL); - return FAILURE; + return NULL; } } if (unlikely (dtp->u.p.current_unit->bytes_left == 0)) { - dtp->u.p.current_unit->endfile = AT_ENDFILE; - generate_error (&dtp->common, LIBERROR_END, NULL); - return FAILURE; + hit_eof (dtp); + return NULL; } *nbytes = dtp->u.p.current_unit->bytes_left; @@ -352,42 +355,36 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) { - nb = *nbytes; - source = read_sf (dtp, &nb, 0); - *nbytes = nb; + source = read_sf (dtp, nbytes, 0); dtp->u.p.current_unit->strm_pos += (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); - if (source == NULL) - return FAILURE; - memcpy (buf, source, *nbytes); - return SUCCESS; + return source; } + + /* If we reach here, we can assume it's direct access. */ + dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; - nread = *nbytes; - if (unlikely (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return FAILURE; - } + norig = *nbytes; + source = fbuf_read (dtp->u.p.current_unit, nbytes); + fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) - dtp->u.p.size_used += (GFC_IO_INT) nread; + dtp->u.p.size_used += (GFC_IO_INT) *nbytes; - if (nread != *nbytes) - { /* Short read, this shouldn't happen. */ - if (likely (dtp->u.p.current_unit->pad_status == PAD_YES)) - *nbytes = nread; - else + if (norig != *nbytes) + { + /* Short read, this shouldn't happen. */ + if (!dtp->u.p.current_unit->pad_status == PAD_YES) { generate_error (&dtp->common, LIBERROR_EOR, NULL); source = NULL; } } - dtp->u.p.current_unit->strm_pos += (gfc_offset) nread; + dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes; - return SUCCESS; + return source; } @@ -395,20 +392,19 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes) unformatted files. */ static void -read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) +read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) { - size_t to_read_record; - size_t have_read_record; - size_t to_read_subrecord; - size_t have_read_subrecord; + ssize_t to_read_record; + ssize_t have_read_record; + ssize_t to_read_subrecord; + ssize_t have_read_subrecord; int short_record; if (is_stream_io (dtp)) { - to_read_record = *nbytes; - have_read_record = to_read_record; - if (unlikely (sread (dtp->u.p.current_unit->s, buf, &have_read_record) - != 0)) + have_read_record = sread (dtp->u.p.current_unit->s, buf, + nbytes); + if (unlikely (have_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; @@ -416,52 +412,48 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; - if (unlikely (to_read_record != have_read_record)) + if (unlikely ((ssize_t) nbytes != have_read_record)) { /* Short read, e.g. if we hit EOF. For stream files, we have to set the end-of-file condition. */ - generate_error (&dtp->common, LIBERROR_END, NULL); - return; + hit_eof (dtp); } return; } if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { - if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) + if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) { short_record = 1; - to_read_record = (size_t) dtp->u.p.current_unit->bytes_left; - *nbytes = to_read_record; + to_read_record = dtp->u.p.current_unit->bytes_left; + nbytes = to_read_record; } - else { short_record = 0; - to_read_record = *nbytes; + to_read_record = nbytes; } dtp->u.p.current_unit->bytes_left -= to_read_record; - if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record) - != 0)) + to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record); + if (unlikely (to_read_record < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } - if (to_read_record != *nbytes) + if (to_read_record != (ssize_t) nbytes) { /* Short read, e.g. if we hit EOF. Apparently, we read more than was written to the last record. */ - *nbytes = to_read_record; return; } if (unlikely (short_record)) { generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); - return; } return; } @@ -470,23 +462,17 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) until the request has been fulfilled or the record has run out of continuation subrecords. */ - if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - return; - } - /* Check whether we exceed the total record length. */ if (dtp->u.p.current_unit->flags.has_recl - && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left)) + && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)) { - to_read_record = (size_t) dtp->u.p.current_unit->bytes_left; + to_read_record = dtp->u.p.current_unit->bytes_left; short_record = 1; } else { - to_read_record = *nbytes; + to_read_record = nbytes; short_record = 0; } have_read_record = 0; @@ -496,7 +482,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) if (dtp->u.p.current_unit->bytes_left_subrecord < (gfc_offset) to_read_record) { - to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord; + to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord; to_read_record -= to_read_subrecord; } else @@ -507,9 +493,9 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; - have_read_subrecord = to_read_subrecord; - if (unlikely (sread (dtp->u.p.current_unit->s, buf + have_read_record, - &have_read_subrecord) != 0)) + have_read_subrecord = sread (dtp->u.p.current_unit->s, + buf + have_read_record, to_read_subrecord); + if (unlikely (have_read_subrecord) < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; @@ -524,7 +510,6 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) structure has been corrupted, or the trailing record marker would still be present. */ - *nbytes = have_read_record; generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); return; } @@ -598,7 +583,7 @@ write_block (st_parameter_dt *dtp, int length) if (is_internal_unit (dtp)) { - dest = salloc_w (dtp->u.p.current_unit->s, &length); + dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); if (dest == NULL) { @@ -636,20 +621,22 @@ static try write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) { - size_t have_written, to_write_subrecord; + ssize_t have_written; + ssize_t to_write_subrecord; int short_record; /* Stream I/O. */ if (is_stream_io (dtp)) { - if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)) + have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); + if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } - dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; + dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; return SUCCESS; } @@ -667,14 +654,15 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) if (buf == NULL && nbytes == 0) return SUCCESS; - if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)) + have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); + if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; } - dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; - dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes; + dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; + dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written; return SUCCESS; } @@ -704,8 +692,9 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) dtp->u.p.current_unit->bytes_left_subrecord -= (gfc_offset) to_write_subrecord; - if (unlikely (swrite (dtp->u.p.current_unit->s, buf + have_written, - &to_write_subrecord) != 0)) + to_write_subrecord = swrite (dtp->u.p.current_unit->s, + buf + have_written, to_write_subrecord); + if (unlikely (to_write_subrecord < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); return FAILURE; @@ -737,20 +726,18 @@ static void unformatted_read (st_parameter_dt *dtp, bt type, void *dest, int kind, size_t size, size_t nelems) { - size_t i, sz; - if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { - sz = size * nelems; if (type == BT_CHARACTER) - sz *= GFC_SIZE_OF_CHAR_KIND(kind); - read_block_direct (dtp, dest, &sz); + size *= GFC_SIZE_OF_CHAR_KIND(kind); + read_block_direct (dtp, dest, size * nelems); } else { char buffer[16]; char *p; + size_t i; p = dest; @@ -773,7 +760,7 @@ unformatted_read (st_parameter_dt *dtp, bt type, for (i = 0; i < nelems; i++) { - read_block_direct (dtp, buffer, &size); + read_block_direct (dtp, buffer, size); reverse_memcpy (p, buffer, size); p += size; } @@ -915,19 +902,18 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) } -/* This subroutine is the main loop for a formatted data transfer +/* This function is in the main loop for a formatted data transfer statement. It would be natural to implement this as a coroutine with the user program, but C makes that awkward. We loop, processing format elements. When we actually have to transfer data instead of just setting flags, we return control to the user - program which calls a subroutine that supplies the address and type + program which calls a function that supplies the address and type of the next element, then comes back here to process it. */ static void -formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, - size_t size) +formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind, + size_t size) { - char scratch[SCRATCH_SIZE]; int pos, bytes_used; const fnode *f; format_token t; @@ -954,7 +940,347 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, dtp->u.p.sf_read_comma = dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; - dtp->u.p.line_buffer = scratch; + for (;;) + { + /* If reversion has occurred and there is another real data item, + then we have to move to the next record. */ + if (dtp->u.p.reversion_flag && n > 0) + { + dtp->u.p.reversion_flag = 0; + next_record (dtp, 0); + } + + consume_data_flag = 1; + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) + break; + + f = next_format (dtp); + if (f == NULL) + { + /* No data descriptors left. */ + if (unlikely (n > 0)) + generate_error (&dtp->common, LIBERROR_FORMAT, + "Insufficient data descriptors in format after reversion"); + return; + } + + t = f->format; + + bytes_used = (int)(dtp->u.p.current_unit->recl + - dtp->u.p.current_unit->bytes_left); + + if (is_stream_io(dtp)) + bytes_used = 0; + + switch (t) + { + case FMT_I: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_INTEGER, type, f)) + return; + read_decimal (dtp, f, p, kind); + break; + + case FMT_B: + if (n == 0) + goto need_read_data; + if (compile_options.allow_std < GFC_STD_GNU + && require_type (dtp, BT_INTEGER, type, f)) + return; + read_radix (dtp, f, p, kind, 2); + break; + + case FMT_O: + if (n == 0) + goto need_read_data; + if (compile_options.allow_std < GFC_STD_GNU + && require_type (dtp, BT_INTEGER, type, f)) + return; + read_radix (dtp, f, p, kind, 8); + break; + + case FMT_Z: + if (n == 0) + goto need_read_data; + if (compile_options.allow_std < GFC_STD_GNU + && require_type (dtp, BT_INTEGER, type, f)) + return; + read_radix (dtp, f, p, kind, 16); + break; + + case FMT_A: + if (n == 0) + goto need_read_data; + + /* It is possible to have FMT_A with something not BT_CHARACTER such + as when writing out hollerith strings, so check both type + and kind before calling wide character routines. */ + if (type == BT_CHARACTER && kind == 4) + read_a_char4 (dtp, f, p, size); + else + read_a (dtp, f, p, size); + break; + + case FMT_L: + if (n == 0) + goto need_read_data; + read_l (dtp, f, p, kind); + break; + + case FMT_D: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_f (dtp, f, p, kind); + break; + + case FMT_E: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_f (dtp, f, p, kind); + break; + + case FMT_EN: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_f (dtp, f, p, kind); + break; + + case FMT_ES: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_f (dtp, f, p, kind); + break; + + case FMT_F: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_f (dtp, f, p, kind); + break; + + case FMT_G: + if (n == 0) + goto need_read_data; + switch (type) + { + case BT_INTEGER: + read_decimal (dtp, f, p, kind); + break; + case BT_LOGICAL: + read_l (dtp, f, p, kind); + break; + case BT_CHARACTER: + if (kind == 4) + read_a_char4 (dtp, f, p, size); + else + read_a (dtp, f, p, size); + break; + case BT_REAL: + read_f (dtp, f, p, kind); + break; + default: + internal_error (&dtp->common, "formatted_transfer(): Bad type"); + } + break; + + case FMT_STRING: + consume_data_flag = 0; + format_error (dtp, f, "Constant string in input format"); + return; + + /* Format codes that don't transfer data. */ + case FMT_X: + case FMT_TR: + consume_data_flag = 0; + dtp->u.p.skips += f->u.n; + pos = bytes_used + dtp->u.p.skips - 1; + dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; + read_x (dtp, f->u.n); + break; + + case FMT_TL: + case FMT_T: + consume_data_flag = 0; + + if (f->format == FMT_TL) + { + /* Handle the special case when no bytes have been used yet. + Cannot go below zero. */ + if (bytes_used == 0) + { + dtp->u.p.pending_spaces -= f->u.n; + dtp->u.p.skips -= f->u.n; + dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; + } + + pos = bytes_used - f->u.n; + } + else /* FMT_T */ + pos = f->u.n - 1; + + /* Standard 10.6.1.1: excessive left tabbing is reset to the + left tab limit. We do not check if the position has gone + beyond the end of record because a subsequent tab could + bring us back again. */ + pos = pos < 0 ? 0 : pos; + + dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; + dtp->u.p.pending_spaces = dtp->u.p.pending_spaces + + pos - dtp->u.p.max_pos; + dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 + ? 0 : dtp->u.p.pending_spaces; + if (dtp->u.p.skips == 0) + break; + + /* Adjust everything for end-of-record condition */ + if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) + { + dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor; + dtp->u.p.skips -= dtp->u.p.sf_seen_eor; + bytes_used = pos; + dtp->u.p.sf_seen_eor = 0; + } + if (dtp->u.p.skips < 0) + { + if (is_internal_unit (dtp)) + sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); + else + fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); + dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; + dtp->u.p.skips = dtp->u.p.pending_spaces = 0; + } + else + read_x (dtp, dtp->u.p.skips); + break; + + case FMT_S: + consume_data_flag = 0; + dtp->u.p.sign_status = SIGN_S; + break; + + case FMT_SS: + consume_data_flag = 0; + dtp->u.p.sign_status = SIGN_SS; + break; + + case FMT_SP: + consume_data_flag = 0; + dtp->u.p.sign_status = SIGN_SP; + break; + + case FMT_BN: + consume_data_flag = 0 ; + dtp->u.p.blank_status = BLANK_NULL; + break; + + case FMT_BZ: + consume_data_flag = 0; + dtp->u.p.blank_status = BLANK_ZERO; + break; + + case FMT_DC: + consume_data_flag = 0; + dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; + break; + + case FMT_DP: + consume_data_flag = 0; + dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; + break; + + case FMT_P: + consume_data_flag = 0; + dtp->u.p.scale_factor = f->u.k; + break; + + case FMT_DOLLAR: + consume_data_flag = 0; + dtp->u.p.seen_dollar = 1; + break; + + case FMT_SLASH: + consume_data_flag = 0; + dtp->u.p.skips = dtp->u.p.pending_spaces = 0; + next_record (dtp, 0); + break; + + case FMT_COLON: + /* A colon descriptor causes us to exit this loop (in + particular preventing another / descriptor from being + processed) unless there is another data item to be + transferred. */ + consume_data_flag = 0; + if (n == 0) + return; + break; + + default: + internal_error (&dtp->common, "Bad format node"); + } + + /* Adjust the item count and data pointer. */ + + if ((consume_data_flag > 0) && (n > 0)) + { + n--; + p = ((char *) p) + size; + } + + dtp->u.p.skips = 0; + + pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); + dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; + } + + return; + + /* Come here when we need a data descriptor but don't have one. We + push the current format node back onto the input, then return and + let the user program call us back with the data. */ + need_read_data: + unget_format (dtp, f); +} + + +static void +formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind, + size_t size) +{ + int pos, bytes_used; + const fnode *f; + format_token t; + int n; + int consume_data_flag; + + /* Change a complex data item into a pair of reals. */ + + n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); + if (type == BT_COMPLEX) + { + type = BT_REAL; + size /= 2; + } + + /* If there's an EOR condition, we simulate finalizing the transfer + by doing nothing. */ + if (dtp->u.p.eor_condition) + return; + + /* Set this flag so that commas in reads cause the read to complete before + the entire field has been read. The next read field will start right after + the comma in the stream. (Set to 0 for character reads). */ + dtp->u.p.sf_read_comma = + dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; for (;;) { @@ -1003,9 +1329,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, if (dtp->u.p.skips < 0) { if (is_internal_unit (dtp)) - move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); + sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); else - fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips); + fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; } dtp->u.p.skips = dtp->u.p.pending_spaces = 0; @@ -1024,57 +1350,34 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_INTEGER, type, f)) return; - - if (dtp->u.p.mode == READING) - read_decimal (dtp, f, p, kind); - else - write_i (dtp, f, p, kind); - + write_i (dtp, f, p, kind); break; case FMT_B: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; - - if (dtp->u.p.mode == READING) - read_radix (dtp, f, p, kind, 2); - else - write_b (dtp, f, p, kind); - + write_b (dtp, f, p, kind); break; case FMT_O: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; - - if (dtp->u.p.mode == READING) - read_radix (dtp, f, p, kind, 8); - else - write_o (dtp, f, p, kind); - + write_o (dtp, f, p, kind); break; case FMT_Z: if (n == 0) goto need_data; - if (compile_options.allow_std < GFC_STD_GNU && require_type (dtp, BT_INTEGER, type, f)) return; - - if (dtp->u.p.mode == READING) - read_radix (dtp, f, p, kind, 16); - else - write_z (dtp, f, p, kind); - + write_z (dtp, f, p, kind); break; case FMT_A: @@ -1084,31 +1387,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, /* It is possible to have FMT_A with something not BT_CHARACTER such as when writing out hollerith strings, so check both type and kind before calling wide character routines. */ - if (dtp->u.p.mode == READING) - { - if (type == BT_CHARACTER && kind == 4) - read_a_char4 (dtp, f, p, size); - else - read_a (dtp, f, p, size); - } + if (type == BT_CHARACTER && kind == 4) + write_a_char4 (dtp, f, p, size); else - { - if (type == BT_CHARACTER && kind == 4) - write_a_char4 (dtp, f, p, size); - else - write_a (dtp, f, p, size); - } + write_a (dtp, f, p, size); break; case FMT_L: if (n == 0) goto need_data; - - if (dtp->u.p.mode == READING) - read_l (dtp, f, p, kind); - else - write_l (dtp, f, p, kind); - + write_l (dtp, f, p, kind); break; case FMT_D: @@ -1116,12 +1404,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - - if (dtp->u.p.mode == READING) - read_f (dtp, f, p, kind); - else - write_d (dtp, f, p, kind); - + write_d (dtp, f, p, kind); break; case FMT_E: @@ -1129,11 +1412,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - - if (dtp->u.p.mode == READING) - read_f (dtp, f, p, kind); - else - write_e (dtp, f, p, kind); + write_e (dtp, f, p, kind); break; case FMT_EN: @@ -1141,12 +1420,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - - if (dtp->u.p.mode == READING) - read_f (dtp, f, p, kind); - else - write_en (dtp, f, p, kind); - + write_en (dtp, f, p, kind); break; case FMT_ES: @@ -1154,12 +1428,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - - if (dtp->u.p.mode == READING) - read_f (dtp, f, p, kind); - else - write_es (dtp, f, p, kind); - + write_es (dtp, f, p, kind); break; case FMT_F: @@ -1167,41 +1436,14 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, goto need_data; if (require_type (dtp, BT_REAL, type, f)) return; - - if (dtp->u.p.mode == READING) - read_f (dtp, f, p, kind); - else - write_f (dtp, f, p, kind); - + write_f (dtp, f, p, kind); break; case FMT_G: if (n == 0) goto need_data; - if (dtp->u.p.mode == READING) - switch (type) - { - case BT_INTEGER: - read_decimal (dtp, f, p, kind); - break; - case BT_LOGICAL: - read_l (dtp, f, p, kind); - break; - case BT_CHARACTER: - if (kind == 4) - read_a_char4 (dtp, f, p, size); - else - read_a (dtp, f, p, size); - break; - case BT_REAL: - read_f (dtp, f, p, kind); - break; - default: - goto bad_type; - } - else - switch (type) - { + switch (type) + { case BT_INTEGER: write_i (dtp, f, p, kind); break; @@ -1216,25 +1458,18 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, break; case BT_REAL: if (f->u.real.w == 0) - write_real_g0 (dtp, p, kind, f->u.real.d); + write_real_g0 (dtp, p, kind, f->u.real.d); else write_d (dtp, f, p, kind); break; default: - bad_type: internal_error (&dtp->common, "formatted_transfer(): Bad type"); - } - + } break; case FMT_STRING: consume_data_flag = 0; - if (dtp->u.p.mode == READING) - { - format_error (dtp, f, "Constant string in input format"); - return; - } write_constant_string (dtp, f); break; @@ -1246,21 +1481,15 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, dtp->u.p.skips += f->u.n; pos = bytes_used + dtp->u.p.skips - 1; dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; - /* Writes occur just before the switch on f->format, above, so that trailing blanks are suppressed, unless we are doing a non-advancing write in which case we want to output the blanks now. */ - if (dtp->u.p.mode == WRITING - && dtp->u.p.advance_status == ADVANCE_NO) + if (dtp->u.p.advance_status == ADVANCE_NO) { write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } - - if (dtp->u.p.mode == READING) - read_x (dtp, f->u.n); - break; case FMT_TL: @@ -1282,12 +1511,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, pos = bytes_used - f->u.n; } else /* FMT_T */ - { - if (dtp->u.p.mode == READING) - pos = f->u.n - 1; - else - pos = f->u.n - dtp->u.p.pending_spaces - 1; - } + pos = f->u.n - dtp->u.p.pending_spaces - 1; /* Standard 10.6.1.1: excessive left tabbing is reset to the left tab limit. We do not check if the position has gone @@ -1300,43 +1524,6 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, + pos - dtp->u.p.max_pos; dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0 : dtp->u.p.pending_spaces; - - if (dtp->u.p.skips == 0) - break; - - /* Writes occur just before the switch on f->format, above, so that - trailing blanks are suppressed. */ - if (dtp->u.p.mode == READING) - { - /* Adjust everything for end-of-record condition */ - if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) - { - if (dtp->u.p.sf_seen_eor == 2) - { - /* The EOR was a CRLF (two bytes wide). */ - dtp->u.p.current_unit->bytes_left -= 2; - dtp->u.p.skips -= 2; - } - else - { - /* The EOR marker was only one byte wide. */ - dtp->u.p.current_unit->bytes_left--; - dtp->u.p.skips--; - } - bytes_used = pos; - dtp->u.p.sf_seen_eor = 0; - } - if (dtp->u.p.skips < 0) - { - move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips); - dtp->u.p.current_unit->bytes_left - -= (gfc_offset) dtp->u.p.skips; - dtp->u.p.skips = dtp->u.p.pending_spaces = 0; - } - else - read_x (dtp, dtp->u.p.skips); - } - break; case FMT_S: @@ -1404,30 +1591,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, internal_error (&dtp->common, "Bad format node"); } - /* Free a buffer that we had to allocate during a sequential - formatted read of a block that was larger than the static - buffer. */ - - if (dtp->u.p.line_buffer != scratch) - { - free_mem (dtp->u.p.line_buffer); - dtp->u.p.line_buffer = scratch; - } - /* Adjust the item count and data pointer. */ if ((consume_data_flag > 0) && (n > 0)) - { - n--; - p = ((char *) p) + size; - } - - if (dtp->u.p.mode == READING) - dtp->u.p.skips = 0; + { + n--; + p = ((char *) p) + size; + } pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; - } return; @@ -1439,6 +1612,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, unget_format (dtp, f); } + static void formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size, size_t nelems) @@ -1449,16 +1623,27 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, tmp = (char *) p; size_t stride = type == BT_CHARACTER ? size * GFC_SIZE_OF_CHAR_KIND(kind) : size; - /* Big loop over all the elements. */ - for (elem = 0; elem < nelems; elem++) + if (dtp->u.p.mode == READING) { - dtp->u.p.item_count++; - formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size); + /* Big loop over all the elements. */ + for (elem = 0; elem < nelems; elem++) + { + dtp->u.p.item_count++; + formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size); + } + } + else + { + /* Big loop over all the elements. */ + for (elem = 0; elem < nelems; elem++) + { + dtp->u.p.item_count++; + formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size); + } } } - /* Data transfer entry points. The type of the data entity is implicit in the subroutine call. This prevents us from having to share a common enum with the compiler. */ @@ -1652,34 +1837,28 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, static void us_read (st_parameter_dt *dtp, int continued) { - size_t n, nr; + ssize_t n, nr; GFC_INTEGER_4 i4; GFC_INTEGER_8 i8; gfc_offset i; - if (dtp->u.p.current_unit->endfile == AT_ENDFILE) - return; - if (compile_options.record_marker == 0) n = sizeof (GFC_INTEGER_4); else n = compile_options.record_marker; - nr = n; - - if (unlikely (sread (dtp->u.p.current_unit->s, &i, &n) != 0)) + nr = sread (dtp->u.p.current_unit->s, &i, n); + if (unlikely (nr < 0)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; } - - if (n == 0) + else if (nr == 0) { - dtp->u.p.current_unit->endfile = AT_ENDFILE; + hit_eof (dtp); return; /* end of file */ } - - if (unlikely (n != nr)) + else if (unlikely (n != nr)) { generate_error (&dtp->common, LIBERROR_BAD_US, NULL); return; @@ -1745,7 +1924,7 @@ us_read (st_parameter_dt *dtp, int continued) static void us_write (st_parameter_dt *dtp, int continued) { - size_t nbytes; + ssize_t nbytes; gfc_offset dummy; dummy = 0; @@ -1755,7 +1934,7 @@ us_write (st_parameter_dt *dtp, int continued) else nbytes = compile_options.record_marker ; - if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0) + if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes) generate_error (&dtp->common, LIBERROR_OS, NULL); /* For sequential unformatted, if RECL= was not specified in the OPEN @@ -1957,7 +2136,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } - /* Check the record number. */ + /* Check the record or position number. */ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT && (cf & IOPARM_DT_HAS_REC) == 0) @@ -2106,65 +2285,70 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; - + + /* Check to see if we might be reading what we wrote before */ + + if (dtp->u.p.mode != dtp->u.p.current_unit->mode + && !is_internal_unit (dtp)) + { + int pos = fbuf_reset (dtp->u.p.current_unit); + if (pos != 0) + sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR); + sflush(dtp->u.p.current_unit->s); + } + /* Check the POS= specifier: that it is in range and that it is used with a unit that has been connected for STREAM access. F2003 9.5.1.10. */ if (((cf & IOPARM_DT_HAS_POS) != 0)) { if (is_stream_io (dtp)) - { - - if (dtp->pos <= 0) - { - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "POS=specifier must be positive"); - return; - } - - if (dtp->pos >= dtp->u.p.current_unit->maxrec) - { - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "POS=specifier too large"); - return; - } - - dtp->rec = dtp->pos; - - if (dtp->u.p.mode == READING) - { - /* Required for compatibility between 4.3 and 4.4 runtime. Check - to see if we might be reading what we wrote before */ - if (dtp->u.p.current_unit->mode == WRITING) - { - fbuf_flush (dtp->u.p.current_unit, 1); - flush(dtp->u.p.current_unit->s); - } - - if (dtp->pos < file_length (dtp->u.p.current_unit->s)) - dtp->u.p.current_unit->endfile = NO_ENDFILE; - } - - if (dtp->pos != dtp->u.p.current_unit->strm_pos) - { - fbuf_flush (dtp->u.p.current_unit, 1); - flush (dtp->u.p.current_unit->s); - if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } - dtp->u.p.current_unit->strm_pos = dtp->pos; - } - } + { + + if (dtp->pos <= 0) + { + generate_error (&dtp->common, LIBERROR_BAD_OPTION, + "POS=specifier must be positive"); + return; + } + + if (dtp->pos >= dtp->u.p.current_unit->maxrec) + { + generate_error (&dtp->common, LIBERROR_BAD_OPTION, + "POS=specifier too large"); + return; + } + + dtp->rec = dtp->pos; + + if (dtp->u.p.mode == READING) + { + /* Reset the endfile flag; if we hit EOF during reading + we'll set the flag and generate an error at that point + rather than worrying about it here. */ + dtp->u.p.current_unit->endfile = NO_ENDFILE; + } + + if (dtp->pos != dtp->u.p.current_unit->strm_pos) + { + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); + if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0) + { + generate_error (&dtp->common, LIBERROR_OS, NULL); + return; + } + dtp->u.p.current_unit->strm_pos = dtp->pos; + } + } else - { - generate_error (&dtp->common, LIBERROR_BAD_OPTION, - "POS=specifier not allowed, " - "Try OPEN with ACCESS='stream'"); - return; - } + { + generate_error (&dtp->common, LIBERROR_BAD_OPTION, + "POS=specifier not allowed, " + "Try OPEN with ACCESS='stream'"); + return; + } } + /* Sanity checks on the record number. */ if ((cf & IOPARM_DT_HAS_REC) != 0) @@ -2183,15 +2367,10 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } - /* Check to see if we might be reading what we wrote before */ + /* Make sure format buffer is reset. */ + if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) + fbuf_reset (dtp->u.p.current_unit); - if (dtp->u.p.mode == READING - && dtp->u.p.current_unit->mode == WRITING - && !is_internal_unit (dtp)) - { - fbuf_flush (dtp->u.p.current_unit, 1); - flush(dtp->u.p.current_unit->s); - } /* Check whether the record exists to be read. Only a partial record needs to exist. */ @@ -2206,37 +2385,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) /* Position the file. */ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) - * dtp->u.p.current_unit->recl) == FAILURE) - { - generate_error (&dtp->common, LIBERROR_OS, NULL); - return; - } + * dtp->u.p.current_unit->recl, SEEK_SET) < 0) + { + generate_error (&dtp->common, LIBERROR_OS, NULL); + return; + } /* TODO: This is required to maintain compatibility between - 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ + 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */ if (is_stream_io (dtp)) - dtp->u.p.current_unit->strm_pos = dtp->rec; - + dtp->u.p.current_unit->strm_pos = dtp->rec; + /* TODO: Un-comment this code when ABI changes from 4.3. if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) - { - generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, - "Record number not allowed for stream access " - "data transfer"); - return; - } */ - + { + generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, + "Record number not allowed for stream access " + "data transfer"); + return; + } */ } - /* Overwriting an existing sequential file ? - it is always safe to truncate the file on the first write */ - if (dtp->u.p.mode == WRITING - && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL - && dtp->u.p.current_unit->last_record == 0 - && !is_preconnected(dtp->u.p.current_unit->s)) - struncate(dtp->u.p.current_unit->s); - /* Bugware for badly written mixed C-Fortran I/O. */ flush_if_preconnected(dtp->u.p.current_unit->s); @@ -2387,11 +2557,10 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) position. */ static void -skip_record (st_parameter_dt *dtp, size_t bytes) +skip_record (st_parameter_dt *dtp, ssize_t bytes) { - gfc_offset new; - size_t rlength; - static const size_t MAX_READ = 4096; + ssize_t rlength, readb; + static const ssize_t MAX_READ = 4096; char p[MAX_READ]; dtp->u.p.current_unit->bytes_left_subrecord += bytes; @@ -2400,12 +2569,10 @@ skip_record (st_parameter_dt *dtp, size_t bytes) if (is_seekable (dtp->u.p.current_unit->s)) { - new = file_position (dtp->u.p.current_unit->s) - + dtp->u.p.current_unit->bytes_left_subrecord; - /* Direct access files do not generate END conditions, only I/O errors. */ - if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) + if (sseek (dtp->u.p.current_unit->s, + dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0) generate_error (&dtp->common, LIBERROR_OS, NULL); } else @@ -2413,16 +2580,17 @@ skip_record (st_parameter_dt *dtp, size_t bytes) while (dtp->u.p.current_unit->bytes_left_subrecord > 0) { rlength = - (MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ? - MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord; + (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ? + MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord; - if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0) + readb = sread (dtp->u.p.current_unit->s, p, rlength); + if (readb < 0) { generate_error (&dtp->common, LIBERROR_OS, NULL); return; } - dtp->u.p.current_unit->bytes_left_subrecord -= rlength; + dtp->u.p.current_unit->bytes_left_subrecord -= readb; } } @@ -2470,8 +2638,8 @@ next_record_r (st_parameter_dt *dtp) { gfc_offset record; int bytes_left; - size_t length; char p; + int cc; switch (current_mode (dtp)) { @@ -2491,11 +2659,12 @@ next_record_r (st_parameter_dt *dtp) case FORMATTED_STREAM: case FORMATTED_SEQUENTIAL: - length = 1; - /* sf_read has already terminated input because of an '\n' */ - if (dtp->u.p.sf_seen_eor) + /* read_sf has already terminated input because of an '\n', or + we have hit EOF. */ + if (dtp->u.p.sf_seen_eor || dtp->u.p.at_eof) { dtp->u.p.sf_seen_eor = 0; + dtp->u.p.at_eof = 0; break; } @@ -2510,7 +2679,7 @@ next_record_r (st_parameter_dt *dtp) /* Now seek to this record. */ record = record * dtp->u.p.current_unit->recl; - if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) + if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; @@ -2522,10 +2691,9 @@ next_record_r (st_parameter_dt *dtp) bytes_left = (int) dtp->u.p.current_unit->bytes_left; bytes_left = min_off (bytes_left, file_length (dtp->u.p.current_unit->s) - - file_position (dtp->u.p.current_unit->s)); + - stell (dtp->u.p.current_unit->s)); if (sseek (dtp->u.p.current_unit->s, - file_position (dtp->u.p.current_unit->s) - + bytes_left) == FAILURE) + bytes_left, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); break; @@ -2535,42 +2703,37 @@ next_record_r (st_parameter_dt *dtp) } break; } - else do + else { - if (sread (dtp->u.p.current_unit->s, &p, &length) != 0) + do { - generate_error (&dtp->common, LIBERROR_OS, NULL); - break; - } - - if (length == 0) - { - dtp->u.p.current_unit->endfile = AT_ENDFILE; - break; + errno = 0; + cc = fbuf_getc (dtp->u.p.current_unit); + if (cc == EOF) + { + if (errno != 0) + generate_error (&dtp->common, LIBERROR_OS, NULL); + else + hit_eof (dtp); + break; + } + + if (is_stream_io (dtp)) + dtp->u.p.current_unit->strm_pos++; + + p = (char) cc; } - - if (is_stream_io (dtp)) - dtp->u.p.current_unit->strm_pos++; + while (p != '\n'); } - while (p != '\n'); - break; } - - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL - && !dtp->u.p.namelist_mode - && dtp->u.p.current_unit->endfile == NO_ENDFILE - && (file_length (dtp->u.p.current_unit->s) == - file_position (dtp->u.p.current_unit->s))) - dtp->u.p.current_unit->endfile = AT_ENDFILE; - } /* Small utility function to write a record marker, taking care of byte swapping and of choosing the correct size. */ -inline static int +static int write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) { size_t len; @@ -2590,12 +2753,12 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) { case sizeof (GFC_INTEGER_4): buf4 = buf; - return swrite (dtp->u.p.current_unit->s, &buf4, &len); + return swrite (dtp->u.p.current_unit->s, &buf4, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; - return swrite (dtp->u.p.current_unit->s, &buf8, &len); + return swrite (dtp->u.p.current_unit->s, &buf8, len); break; default: @@ -2610,13 +2773,13 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) case sizeof (GFC_INTEGER_4): buf4 = buf; reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4)); - return swrite (dtp->u.p.current_unit->s, p, &len); + return swrite (dtp->u.p.current_unit->s, p, len); break; case sizeof (GFC_INTEGER_8): buf8 = buf; reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8)); - return swrite (dtp->u.p.current_unit->s, p, &len); + return swrite (dtp->u.p.current_unit->s, p, len); break; default: @@ -2633,13 +2796,11 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) static void next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) { - gfc_offset c, m, m_write; - size_t record_marker; + gfc_offset m, m_write, record_marker; /* Bytes written. */ m = dtp->u.p.current_unit->recl_subrecord - dtp->u.p.current_unit->bytes_left_subrecord; - c = file_position (dtp->u.p.current_unit->s); /* Write the length tail. If we finish a record containing subrecords, we write out the negative length. */ @@ -2649,7 +2810,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) else m_write = m; - if (unlikely (write_us_marker (dtp, m_write) != 0)) + if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; if (compile_options.record_marker == 0) @@ -2660,8 +2821,8 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) /* Seek to the head and overwrite the bogus length with the real length. */ - if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker) - == FAILURE)) + if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker, + SEEK_CUR) < 0)) goto io_error; if (next_subrecord) @@ -2669,13 +2830,13 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) else m_write = m; - if (unlikely (write_us_marker (dtp, m_write) != 0)) + if (unlikely (write_us_marker (dtp, m_write) < 0)) goto io_error; /* Seek past the end of the current record. */ - if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker) - == FAILURE)) + if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker, + SEEK_CUR) < 0)) goto io_error; return; @@ -2686,6 +2847,35 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) } + +/* Utility function like memset() but operating on streams. Return + value is same as for POSIX write(). */ + +static ssize_t +sset (stream * s, int c, ssize_t nbyte) +{ + static const int WRITE_CHUNK = 256; + char p[WRITE_CHUNK]; + ssize_t bytes_left, trans; + + if (nbyte < WRITE_CHUNK) + memset (p, c, nbyte); + else + memset (p, c, WRITE_CHUNK); + + bytes_left = nbyte; + while (bytes_left > 0) + { + trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK; + trans = swrite (s, p, trans); + if (trans < 0) + return trans; + bytes_left -= trans; + } + + return nbyte - bytes_left; +} + /* Position to the next record in write mode. */ static void @@ -2694,9 +2884,6 @@ next_record_w (st_parameter_dt *dtp, int done) gfc_offset m, record, max_pos; int length; - /* Flush and reset the format buffer. */ - fbuf_flush (dtp->u.p.current_unit, 1); - /* Zero counters for X- and T-editing. */ max_pos = dtp->u.p.max_pos; dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; @@ -2711,8 +2898,11 @@ next_record_w (st_parameter_dt *dtp, int done) if (dtp->u.p.current_unit->bytes_left == 0) break; + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); + fbuf_flush (dtp->u.p.current_unit, WRITING); if (sset (dtp->u.p.current_unit->s, ' ', - dtp->u.p.current_unit->bytes_left) == FAILURE) + dtp->u.p.current_unit->bytes_left) + != dtp->u.p.current_unit->bytes_left) goto io_error; break; @@ -2721,7 +2911,7 @@ next_record_w (st_parameter_dt *dtp, int done) if (dtp->u.p.current_unit->bytes_left > 0) { length = (int) dtp->u.p.current_unit->bytes_left; - if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE) + if (sset (dtp->u.p.current_unit->s, 0, length) != length) goto io_error; } break; @@ -2752,8 +2942,7 @@ next_record_w (st_parameter_dt *dtp, int done) { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, - file_position (dtp->u.p.current_unit->s) - + length) == FAILURE) + length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; @@ -2761,7 +2950,7 @@ next_record_w (st_parameter_dt *dtp, int done) length = (int) (dtp->u.p.current_unit->recl - max_pos); } - if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) + if (sset (dtp->u.p.current_unit->s, ' ', length) != length) { generate_error (&dtp->common, LIBERROR_END, NULL); return; @@ -2777,7 +2966,7 @@ next_record_w (st_parameter_dt *dtp, int done) /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; - if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) + if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; @@ -2800,8 +2989,7 @@ next_record_w (st_parameter_dt *dtp, int done) { length = (int) (max_pos - m); if (sseek (dtp->u.p.current_unit->s, - file_position (dtp->u.p.current_unit->s) - + length) == FAILURE) + length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; @@ -2812,7 +3000,7 @@ next_record_w (st_parameter_dt *dtp, int done) length = (int) dtp->u.p.current_unit->bytes_left; } - if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE) + if (sset (dtp->u.p.current_unit->s, ' ', length) != length) { generate_error (&dtp->common, LIBERROR_END, NULL); return; @@ -2821,23 +3009,27 @@ next_record_w (st_parameter_dt *dtp, int done) } else { - size_t len; - const char crlf[] = "\r\n"; - #ifdef HAVE_CRLF - len = 2; + const int len = 2; #else - len = 1; + const int len = 1; #endif - if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0) - goto io_error; - + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); + char * p = fbuf_alloc (dtp->u.p.current_unit, len); + if (!p) + goto io_error; +#ifdef HAVE_CRLF + *(p++) = '\r'; +#endif + *p = '\n'; if (is_stream_io (dtp)) { dtp->u.p.current_unit->strm_pos += len; if (dtp->u.p.current_unit->strm_pos < file_length (dtp->u.p.current_unit->s)) - struncate (dtp->u.p.current_unit->s); + unit_truncate (dtp->u.p.current_unit, + dtp->u.p.current_unit->strm_pos - 1, + &dtp->common); } } @@ -2875,7 +3067,7 @@ next_record (st_parameter_dt *dtp, int done) dtp->u.p.current_unit->current_record = 0; if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { - fp = file_position (dtp->u.p.current_unit->s); + fp = stell (dtp->u.p.current_unit->s); /* Calculate next record, rounding up partial records. */ dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) / @@ -2887,6 +3079,8 @@ next_record (st_parameter_dt *dtp, int done) if (!done) pre_position (dtp); + + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); } @@ -2935,7 +3129,6 @@ finalize_transfer (st_parameter_dt *dtp) if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) { finish_list_read (dtp); - sfree (dtp->u.p.current_unit->s); return; } @@ -2949,12 +3142,6 @@ finalize_transfer (st_parameter_dt *dtp) && dtp->u.p.advance_status != ADVANCE_NO) next_record (dtp, 1); - if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED - && file_position (dtp->u.p.current_unit->s) >= dtp->rec) - { - flush (dtp->u.p.current_unit->s); - sfree (dtp->u.p.current_unit->s); - } return; } @@ -2962,9 +3149,8 @@ finalize_transfer (st_parameter_dt *dtp) if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar) { + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); dtp->u.p.seen_dollar = 0; - fbuf_flush (dtp->u.p.current_unit, 1); - sfree (dtp->u.p.current_unit->s); return; } @@ -2976,15 +3162,16 @@ finalize_transfer (st_parameter_dt *dtp) - dtp->u.p.current_unit->bytes_left); dtp->u.p.current_unit->saved_pos = dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0; - fbuf_flush (dtp->u.p.current_unit, 0); - flush (dtp->u.p.current_unit->s); + fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); return; } + else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED + && dtp->u.p.mode == WRITING && !is_internal_unit (dtp)) + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); dtp->u.p.current_unit->saved_pos = 0; next_record (dtp, 1); - sfree (dtp->u.p.current_unit->s); } /* Transfer function for IOLENGTH. It doesn't actually do any @@ -2997,7 +3184,7 @@ iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), size_t size, size_t nelems) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) - *dtp->iolength += (GFC_IO_INT) size * nelems; + *dtp->iolength += (GFC_IO_INT) (size * nelems); } @@ -3041,8 +3228,6 @@ void st_iolength_done (st_parameter_dt *dtp __attribute__((unused))) { free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); library_end (); } @@ -3058,29 +3243,6 @@ st_read (st_parameter_dt *dtp) library_start (&dtp->common); data_transfer_init (dtp, 1); - - /* Handle complications dealing with the endfile record. */ - - if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) - switch (dtp->u.p.current_unit->endfile) - { - case NO_ENDFILE: - break; - - case AT_ENDFILE: - if (!is_internal_unit (dtp)) - { - generate_error (&dtp->common, LIBERROR_END, NULL); - dtp->u.p.current_unit->endfile = AFTER_ENDFILE; - dtp->u.p.current_unit->current_record = 0; - } - break; - - case AFTER_ENDFILE: - generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); - dtp->u.p.current_unit->current_record = 0; - break; - } } extern void st_read_done (st_parameter_dt *); @@ -3092,8 +3254,6 @@ st_read_done (st_parameter_dt *dtp) finalize_transfer (dtp); free_format_data (dtp); free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); @@ -3136,19 +3296,15 @@ st_write_done (st_parameter_dt *dtp) case NO_ENDFILE: /* Get rid of whatever is after this record. */ if (!is_internal_unit (dtp)) - { - flush (dtp->u.p.current_unit->s); - if (struncate (dtp->u.p.current_unit->s) == FAILURE) - generate_error (&dtp->common, LIBERROR_OS, NULL); - } + unit_truncate (dtp->u.p.current_unit, + stell (dtp->u.p.current_unit->s), + &dtp->common); dtp->u.p.current_unit->endfile = AT_ENDFILE; break; } free_format_data (dtp); free_ionml (dtp); - if (dtp->u.p.scratch != NULL) - free_mem (dtp->u.p.scratch); if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); @@ -3262,3 +3418,46 @@ void reverse_memcpy (void *dest, const void *src, size_t n) for (i=0; i<n; i++) *(d++) = *(s--); } + + +/* Once upon a time, a poor innocent Fortran program was reading a + file, when suddenly it hit the end-of-file (EOF). Unfortunately + the OS doesn't tell whether we're at the EOF or whether we already + went past it. Luckily our hero, libgfortran, keeps track of this. + Call this function when you detect an EOF condition. See Section + 9.10.2 in F2003. */ + +void +hit_eof (st_parameter_dt * dtp) +{ + dtp->u.p.current_unit->flags.position = POSITION_APPEND; + + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (dtp->u.p.current_unit->endfile) + { + case NO_ENDFILE: + case AT_ENDFILE: + generate_error (&dtp->common, LIBERROR_END, NULL); + if (!is_internal_unit (dtp)) + { + dtp->u.p.current_unit->endfile = AFTER_ENDFILE; + dtp->u.p.current_unit->current_record = 0; + } + else + dtp->u.p.current_unit->endfile = AT_ENDFILE; + break; + + case AFTER_ENDFILE: + generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); + dtp->u.p.current_unit->current_record = 0; + break; + } + else + { + /* Non-sequential files don't have an ENDFILE record, so we + can't be at AFTER_ENDFILE. */ + dtp->u.p.current_unit->endfile = AT_ENDFILE; + generate_error (&dtp->common, LIBERROR_END, NULL); + dtp->u.p.current_unit->current_record = 0; + } +} |