diff options
Diffstat (limited to 'libgfortran/io/transfer.c')
| -rw-r--r-- | libgfortran/io/transfer.c | 1135 |
1 files changed, 581 insertions, 554 deletions
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index ae256ccc5bc..a4ea81c1b03 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -63,40 +63,25 @@ Boston, MA 02110-1301, USA. */ st_write(), an error inhibits any data from actually being transferred. */ -extern void transfer_integer (void *, int); +extern void transfer_integer (st_parameter_dt *, void *, int); export_proto(transfer_integer); -extern void transfer_real (void *, int); +extern void transfer_real (st_parameter_dt *, void *, int); export_proto(transfer_real); -extern void transfer_logical (void *, int); +extern void transfer_logical (st_parameter_dt *, void *, int); export_proto(transfer_logical); -extern void transfer_character (void *, int); +extern void transfer_character (st_parameter_dt *, void *, int); export_proto(transfer_character); -extern void transfer_complex (void *, int); +extern void transfer_complex (st_parameter_dt *, void *, int); export_proto(transfer_complex); -extern void transfer_array (gfc_array_char *, int, gfc_charlen_type); +extern void transfer_array (st_parameter_dt *, gfc_array_char *, int, + gfc_charlen_type); export_proto(transfer_array); -gfc_unit *current_unit = NULL; -static int sf_seen_eor = 0; -static int eor_condition = 0; - -/* Maximum righthand column written to. */ -static int max_pos; -/* Number of skips + spaces to be done for T and X-editing. */ -static int skips; -/* Number of spaces to be done for T and X-editing. */ -static int pending_spaces; - -char scratch[SCRATCH_SIZE]; -static char *line_buffer = NULL; - -static unit_advance advance_status; - static const st_option advance_opt[] = { {"yes", ADVANCE_YES}, {"no", ADVANCE_NO}, @@ -104,9 +89,6 @@ static const st_option advance_opt[] = { }; -static void (*transfer) (bt, void *, int, size_t, size_t); - - typedef enum { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, FORMATTED_DIRECT, UNFORMATTED_DIRECT @@ -115,18 +97,18 @@ file_mode; static file_mode -current_mode (void) +current_mode (st_parameter_dt *dtp) { file_mode m; - if (current_unit->flags.access == ACCESS_DIRECT) + if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { - m = current_unit->flags.form == FORM_FORMATTED ? + m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? FORMATTED_DIRECT : UNFORMATTED_DIRECT; } else { - m = current_unit->flags.form == FORM_FORMATTED ? + m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; } @@ -151,20 +133,18 @@ current_mode (void) heap. Hopefully this won't happen very often. */ static char * -read_sf (int *length) +read_sf (st_parameter_dt *dtp, int *length) { - static char data[SCRATCH_SIZE]; char *base, *p, *q; int n, readlen; if (*length > SCRATCH_SIZE) - p = base = line_buffer = get_mem (*length); - else - p = base = data; + dtp->u.p.line_buffer = get_mem (*length); + p = base = dtp->u.p.line_buffer; /* If we have seen an eor previously, return a length of 0. The caller is responsible for correctly padding the input field. */ - if (sf_seen_eor) + if (dtp->u.p.sf_seen_eor) { *length = 0; return base; @@ -175,14 +155,14 @@ read_sf (int *length) do { - if (is_internal_unit()) + if (is_internal_unit (dtp)) { /* readlen may be modified inside salloc_r if - is_internal_unit() is true. */ + is_internal_unit (dtp) is true. */ readlen = 1; } - q = salloc_r (current_unit->s, &readlen); + q = salloc_r (dtp->u.p.current_unit->s, &readlen); if (q == NULL) break; @@ -190,7 +170,7 @@ read_sf (int *length) EOR below. */ if (readlen < 1 && n == 0) { - generate_error (ERROR_END, NULL); + generate_error (&dtp->common, ERROR_END, NULL); return NULL; } @@ -200,32 +180,32 @@ read_sf (int *length) /* If we see an EOR during non-advancing I/O, we need to skip the rest of the I/O statement. Set the corresponding flag. */ - if (advance_status == ADVANCE_NO || g.seen_dollar) - eor_condition = 1; + if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) + dtp->u.p.eor_condition = 1; /* Without padding, terminate the I/O statement without assigning the value. With padding, the value still needs to be assigned, so we can just continue with a short read. */ - if (current_unit->flags.pad == PAD_NO) + if (dtp->u.p.current_unit->flags.pad == PAD_NO) { - generate_error (ERROR_EOR, NULL); + generate_error (&dtp->common, ERROR_EOR, NULL); return NULL; } *length = n; - sf_seen_eor = 1; + dtp->u.p.sf_seen_eor = 1; break; } n++; *p++ = *q; - sf_seen_eor = 0; + dtp->u.p.sf_seen_eor = 0; } while (n < *length); - current_unit->bytes_left -= *length; + dtp->u.p.current_unit->bytes_left -= *length; - if (ioparm.size != NULL) - *ioparm.size += *length; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size += *length; return base; } @@ -242,41 +222,42 @@ read_sf (int *length) short reads. */ void * -read_block (int *length) +read_block (st_parameter_dt *dtp, int *length) { char *source; int nread; - if (current_unit->bytes_left < *length) + if (dtp->u.p.current_unit->bytes_left < *length) { - if (current_unit->flags.pad == PAD_NO) + if (dtp->u.p.current_unit->flags.pad == PAD_NO) { - generate_error (ERROR_EOR, NULL); /* Not enough data left. */ + generate_error (&dtp->common, ERROR_EOR, NULL); + /* Not enough data left. */ return NULL; } - *length = current_unit->bytes_left; + *length = dtp->u.p.current_unit->bytes_left; } - if (current_unit->flags.form == FORM_FORMATTED && - current_unit->flags.access == ACCESS_SEQUENTIAL) - return read_sf (length); /* Special case. */ + if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && + dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + return read_sf (dtp, length); /* Special case. */ - current_unit->bytes_left -= *length; + dtp->u.p.current_unit->bytes_left -= *length; nread = *length; - source = salloc_r (current_unit->s, &nread); + source = salloc_r (dtp->u.p.current_unit->s, &nread); - if (ioparm.size != NULL) - *ioparm.size += nread; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size += nread; if (nread != *length) { /* Short read, this shouldn't happen. */ - if (current_unit->flags.pad == PAD_YES) + if (dtp->u.p.current_unit->flags.pad == PAD_YES) *length = nread; else { - generate_error (ERROR_EOR, NULL); + generate_error (&dtp->common, ERROR_EOR, NULL); source = NULL; } } @@ -288,53 +269,54 @@ read_block (int *length) /* Reads a block directly into application data space. */ static void -read_block_direct (void * buf, size_t * nbytes) +read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { int *length; void *data; size_t nread; - if (current_unit->bytes_left < *nbytes) + if (dtp->u.p.current_unit->bytes_left < *nbytes) { - if (current_unit->flags.pad == PAD_NO) + if (dtp->u.p.current_unit->flags.pad == PAD_NO) { - generate_error (ERROR_EOR, NULL); /* Not enough data left. */ + /* Not enough data left. */ + generate_error (&dtp->common, ERROR_EOR, NULL); return; } - *nbytes = current_unit->bytes_left; + *nbytes = dtp->u.p.current_unit->bytes_left; } - if (current_unit->flags.form == FORM_FORMATTED && - current_unit->flags.access == ACCESS_SEQUENTIAL) + if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && + dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) { - length = (int*) nbytes; - data = read_sf (length); /* Special case. */ + length = (int *) nbytes; + data = read_sf (dtp, length); /* Special case. */ memcpy (buf, data, (size_t) *length); return; } - current_unit->bytes_left -= *nbytes; + dtp->u.p.current_unit->bytes_left -= *nbytes; nread = *nbytes; - if (sread (current_unit->s, buf, &nread) != 0) + if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0) { - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); return; } - if (ioparm.size != NULL) - *ioparm.size += (GFC_INTEGER_4) nread; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size += (GFC_INTEGER_4) nread; if (nread != *nbytes) { /* Short read, e.g. if we hit EOF. */ - if (current_unit->flags.pad == PAD_YES) + if (dtp->u.p.current_unit->flags.pad == PAD_YES) { memset (((char *) buf) + nread, ' ', *nbytes - nread); *nbytes = nread; } else - generate_error (ERROR_EOR, NULL); + generate_error (&dtp->common, ERROR_EOR, NULL); } } @@ -345,27 +327,27 @@ read_block_direct (void * buf, size_t * nbytes) fill in. Returns NULL on error. */ void * -write_block (int length) +write_block (st_parameter_dt *dtp, int length) { char *dest; - if (current_unit->bytes_left < length) + if (dtp->u.p.current_unit->bytes_left < length) { - generate_error (ERROR_EOR, NULL); + generate_error (&dtp->common, ERROR_EOR, NULL); return NULL; } - current_unit->bytes_left -= (gfc_offset)length; - dest = salloc_w (current_unit->s, &length); + dtp->u.p.current_unit->bytes_left -= (gfc_offset) length; + dest = salloc_w (dtp->u.p.current_unit->s, &length); if (dest == NULL) { - generate_error (ERROR_END, NULL); + generate_error (&dtp->common, ERROR_END, NULL); return NULL; } - if (ioparm.size != NULL) - *ioparm.size += length; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size += length; return dest; } @@ -375,44 +357,44 @@ write_block (int length) buffer. */ static void -write_block_direct (void * buf, size_t * nbytes) +write_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes) { - if (current_unit->bytes_left < *nbytes) - generate_error (ERROR_EOR, NULL); + if (dtp->u.p.current_unit->bytes_left < *nbytes) + generate_error (&dtp->common, ERROR_EOR, NULL); - current_unit->bytes_left -= (gfc_offset) *nbytes; + dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; - if (swrite (current_unit->s, buf, nbytes) != 0) - generate_error (ERROR_OS, NULL); + if (swrite (dtp->u.p.current_unit->s, buf, nbytes) != 0) + generate_error (&dtp->common, ERROR_OS, NULL); - if (ioparm.size != NULL) - *ioparm.size += (GFC_INTEGER_4) *nbytes; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size += (GFC_INTEGER_4) *nbytes; } /* Master function for unformatted reads. */ static void -unformatted_read (bt type __attribute__((unused)), void *dest, - int kind __attribute__((unused)), - size_t size, size_t nelems) +unformatted_read (st_parameter_dt *dtp, bt type __attribute__((unused)), + void *dest, int kind __attribute__((unused)), + size_t size, size_t nelems) { size *= nelems; - read_block_direct (dest, &size); + read_block_direct (dtp, dest, &size); } /* Master function for unformatted writes. */ static void -unformatted_write (bt type __attribute__((unused)), void *source, - int kind __attribute__((unused)), - size_t size, size_t nelems) +unformatted_write (st_parameter_dt *dtp, bt type __attribute__((unused)), + void *source, int kind __attribute__((unused)), + size_t size, size_t nelems) { size *= nelems; - write_block_direct (source, &size); + write_block_direct (dtp, source, &size); } @@ -441,7 +423,7 @@ type_name (bt type) p = "COMPLEX"; break; default: - internal_error ("type_name(): Bad type"); + internal_error (NULL, "type_name(): Bad type"); } return p; @@ -453,7 +435,7 @@ type_name (bt type) in it. The length in the format node is the true length. */ static void -write_constant_string (fnode * f) +write_constant_string (st_parameter_dt *dtp, const fnode *f) { char c, delimiter, *p, *q; int length; @@ -462,7 +444,7 @@ write_constant_string (fnode * f) if (length == 0) return; - p = write_block (length); + p = write_block (dtp, length); if (p == NULL) return; @@ -483,7 +465,7 @@ write_constant_string (fnode * f) nonzero if something went wrong. */ static int -require_type (bt expected, bt actual, fnode * f) +require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) { char buffer[100]; @@ -491,9 +473,9 @@ require_type (bt expected, bt actual, fnode * f) return 0; st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s", - type_name (expected), g.item_count, type_name (actual)); + type_name (expected), dtp->u.p.item_count, type_name (actual)); - format_error (f, buffer); + format_error (dtp, f, buffer); return 1; } @@ -507,10 +489,12 @@ require_type (bt expected, bt actual, fnode * f) of the next element, then comes back here to process it. */ static void -formatted_transfer_scalar (bt type, void *p, int len, size_t size) +formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len, + size_t size) { + char scratch[SCRATCH_SIZE]; int pos, bytes_used; - fnode *f; + const fnode *f; format_token t; int n; int consume_data_flag; @@ -526,24 +510,25 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) /* If there's an EOR condition, we simulate finalizing the transfer by doing nothing. */ - if (eor_condition) + if (dtp->u.p.eor_condition) return; + 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 (g.reversion_flag && n > 0) + if (dtp->u.p.reversion_flag && n > 0) { - g.reversion_flag = 0; - next_record (0); + dtp->u.p.reversion_flag = 0; + next_record (dtp, 0); } consume_data_flag = 1 ; - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) break; - f = next_format (); + f = next_format (dtp); if (f == NULL) return; /* No data descriptors left (already raised). */ @@ -551,53 +536,54 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) until a data producing format to suppress trailing spaces. */ t = f->format; - if (g.mode == WRITING && skips != 0 + if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F || t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L || t == FMT_A || t == FMT_D)) || t == FMT_STRING)) { - if (skips > 0) + if (dtp->u.p.skips > 0) { - write_x (skips, pending_spaces); - max_pos = (int)(current_unit->recl - current_unit->bytes_left); + write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); + dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl + - dtp->u.p.current_unit->bytes_left); } - if (skips < 0) + if (dtp->u.p.skips < 0) { - move_pos_offset (current_unit->s, skips); - current_unit->bytes_left -= (gfc_offset)skips; + 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; } - skips = pending_spaces = 0; + dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } - bytes_used = (int)(current_unit->recl - current_unit->bytes_left); + bytes_used = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); switch (t) { case FMT_I: if (n == 0) goto need_data; - if (require_type (BT_INTEGER, type, f)) + if (require_type (dtp, BT_INTEGER, type, f)) return; - if (g.mode == READING) - read_decimal (f, p, len); + if (dtp->u.p.mode == READING) + read_decimal (dtp, f, p, len); else - write_i (f, p, len); + write_i (dtp, f, p, len); break; case FMT_B: if (n == 0) goto need_data; - if (require_type (BT_INTEGER, type, f)) + if (require_type (dtp, BT_INTEGER, type, f)) return; - if (g.mode == READING) - read_radix (f, p, len, 2); + if (dtp->u.p.mode == READING) + read_radix (dtp, f, p, len, 2); else - write_b (f, p, len); + write_b (dtp, f, p, len); break; @@ -605,10 +591,10 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) if (n == 0) goto need_data; - if (g.mode == READING) - read_radix (f, p, len, 8); + if (dtp->u.p.mode == READING) + read_radix (dtp, f, p, len, 8); else - write_o (f, p, len); + write_o (dtp, f, p, len); break; @@ -616,10 +602,10 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) if (n == 0) goto need_data; - if (g.mode == READING) - read_radix (f, p, len, 16); + if (dtp->u.p.mode == READING) + read_radix (dtp, f, p, len, 16); else - write_z (f, p, len); + write_z (dtp, f, p, len); break; @@ -627,10 +613,10 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) if (n == 0) goto need_data; - if (g.mode == READING) - read_a (f, p, len); + if (dtp->u.p.mode == READING) + read_a (dtp, f, p, len); else - write_a (f, p, len); + write_a (dtp, f, p, len); break; @@ -638,94 +624,94 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) if (n == 0) goto need_data; - if (g.mode == READING) - read_l (f, p, len); + if (dtp->u.p.mode == READING) + read_l (dtp, f, p, len); else - write_l (f, p, len); + write_l (dtp, f, p, len); break; case FMT_D: if (n == 0) goto need_data; - if (require_type (BT_REAL, type, f)) + if (require_type (dtp, BT_REAL, type, f)) return; - if (g.mode == READING) - read_f (f, p, len); + if (dtp->u.p.mode == READING) + read_f (dtp, f, p, len); else - write_d (f, p, len); + write_d (dtp, f, p, len); break; case FMT_E: if (n == 0) goto need_data; - if (require_type (BT_REAL, type, f)) + if (require_type (dtp, BT_REAL, type, f)) return; - if (g.mode == READING) - read_f (f, p, len); + if (dtp->u.p.mode == READING) + read_f (dtp, f, p, len); else - write_e (f, p, len); + write_e (dtp, f, p, len); break; case FMT_EN: if (n == 0) goto need_data; - if (require_type (BT_REAL, type, f)) + if (require_type (dtp, BT_REAL, type, f)) return; - if (g.mode == READING) - read_f (f, p, len); + if (dtp->u.p.mode == READING) + read_f (dtp, f, p, len); else - write_en (f, p, len); + write_en (dtp, f, p, len); break; case FMT_ES: if (n == 0) goto need_data; - if (require_type (BT_REAL, type, f)) + if (require_type (dtp, BT_REAL, type, f)) return; - if (g.mode == READING) - read_f (f, p, len); + if (dtp->u.p.mode == READING) + read_f (dtp, f, p, len); else - write_es (f, p, len); + write_es (dtp, f, p, len); break; case FMT_F: if (n == 0) goto need_data; - if (require_type (BT_REAL, type, f)) + if (require_type (dtp, BT_REAL, type, f)) return; - if (g.mode == READING) - read_f (f, p, len); + if (dtp->u.p.mode == READING) + read_f (dtp, f, p, len); else - write_f (f, p, len); + write_f (dtp, f, p, len); break; case FMT_G: if (n == 0) goto need_data; - if (g.mode == READING) + if (dtp->u.p.mode == READING) switch (type) { case BT_INTEGER: - read_decimal (f, p, len); + read_decimal (dtp, f, p, len); break; case BT_LOGICAL: - read_l (f, p, len); + read_l (dtp, f, p, len); break; case BT_CHARACTER: - read_a (f, p, len); + read_a (dtp, f, p, len); break; case BT_REAL: - read_f (f, p, len); + read_f (dtp, f, p, len); break; default: goto bad_type; @@ -734,32 +720,33 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) switch (type) { case BT_INTEGER: - write_i (f, p, len); + write_i (dtp, f, p, len); break; case BT_LOGICAL: - write_l (f, p, len); + write_l (dtp, f, p, len); break; case BT_CHARACTER: - write_a (f, p, len); + write_a (dtp, f, p, len); break; case BT_REAL: - write_d (f, p, len); + write_d (dtp, f, p, len); break; default: bad_type: - internal_error ("formatted_transfer(): Bad type"); + internal_error (&dtp->common, + "formatted_transfer(): Bad type"); } break; case FMT_STRING: consume_data_flag = 0 ; - if (g.mode == READING) + if (dtp->u.p.mode == READING) { - format_error (f, "Constant string in input format"); + format_error (dtp, f, "Constant string in input format"); return; } - write_constant_string (f); + write_constant_string (dtp, f); break; /* Format codes that don't transfer data. */ @@ -767,21 +754,22 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) case FMT_TR: consume_data_flag = 0 ; - pos = bytes_used + f->u.n + skips; - skips = f->u.n + skips; - pending_spaces = pos - max_pos; + pos = bytes_used + f->u.n + dtp->u.p.skips; + dtp->u.p.skips = f->u.n + dtp->u.p.skips; + dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos; /* 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 (g.mode == WRITING && advance_status == ADVANCE_NO) + if (dtp->u.p.mode == WRITING + && dtp->u.p.advance_status == ADVANCE_NO) { - write_x (skips, pending_spaces); - skips = pending_spaces = 0; + write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); + dtp->u.p.skips = dtp->u.p.pending_spaces = 0; } - if (g.mode == READING) - read_x (f->u.n); + if (dtp->u.p.mode == READING) + read_x (dtp, f->u.n); break; @@ -801,75 +789,77 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) bring us back again. */ pos = pos < 0 ? 0 : pos; - skips = skips + pos - bytes_used; - pending_spaces = pending_spaces + pos - max_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; - if (skips == 0) + if (dtp->u.p.skips == 0) break; /* Writes occur just before the switch on f->format, above, so that trailing blanks are suppressed. */ - if (g.mode == READING) + if (dtp->u.p.mode == READING) { /* Adjust everything for end-of-record condition */ - if (sf_seen_eor && !is_internal_unit()) + if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) { - current_unit->bytes_left--; + dtp->u.p.current_unit->bytes_left--; bytes_used = pos; - sf_seen_eor = 0; - skips--; + dtp->u.p.sf_seen_eor = 0; + dtp->u.p.skips--; } - if (skips < 0) + if (dtp->u.p.skips < 0) { - move_pos_offset (current_unit->s, skips); - current_unit->bytes_left -= (gfc_offset)skips; - skips = pending_spaces = 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 (skips); + read_x (dtp, dtp->u.p.skips); } break; case FMT_S: consume_data_flag = 0 ; - g.sign_status = SIGN_S; + dtp->u.p.sign_status = SIGN_S; break; case FMT_SS: consume_data_flag = 0 ; - g.sign_status = SIGN_SS; + dtp->u.p.sign_status = SIGN_SS; break; case FMT_SP: consume_data_flag = 0 ; - g.sign_status = SIGN_SP; + dtp->u.p.sign_status = SIGN_SP; break; case FMT_BN: consume_data_flag = 0 ; - g.blank_status = BLANK_NULL; + dtp->u.p.blank_status = BLANK_NULL; break; case FMT_BZ: consume_data_flag = 0 ; - g.blank_status = BLANK_ZERO; + dtp->u.p.blank_status = BLANK_ZERO; break; case FMT_P: consume_data_flag = 0 ; - g.scale_factor = f->u.k; + dtp->u.p.scale_factor = f->u.k; break; case FMT_DOLLAR: consume_data_flag = 0 ; - g.seen_dollar = 1; + dtp->u.p.seen_dollar = 1; break; case FMT_SLASH: consume_data_flag = 0 ; - skips = pending_spaces = 0; - next_record (0); + dtp->u.p.skips = dtp->u.p.pending_spaces = 0; + next_record (dtp, 0); break; case FMT_COLON: @@ -883,17 +873,17 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) break; default: - internal_error ("Bad format node"); + 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 (line_buffer != NULL) + if (dtp->u.p.line_buffer != scratch) { - free_mem (line_buffer); - line_buffer = NULL; + free_mem (dtp->u.p.line_buffer); + dtp->u.p.line_buffer = scratch; } /* Adjust the item count and data pointer. */ @@ -904,11 +894,11 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) p = ((char *) p) + size; } - if (g.mode == READING) - skips = 0; + if (dtp->u.p.mode == READING) + dtp->u.p.skips = 0; - pos = (int)(current_unit->recl - current_unit->bytes_left); - max_pos = (max_pos > pos) ? max_pos : pos; + 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; } @@ -918,11 +908,12 @@ formatted_transfer_scalar (bt type, void *p, int len, size_t size) push the current format node back onto the input, then return and let the user program call us back with the data. */ need_data: - unget_format (f); + unget_format (dtp, f); } static void -formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems) +formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, + size_t size, size_t nelems) { size_t elem; char *tmp; @@ -932,8 +923,8 @@ formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems) /* Big loop over all the elements. */ for (elem = 0; elem < nelems; elem++) { - g.item_count++; - formatted_transfer_scalar (type, tmp + size*elem, kind, size); + dtp->u.p.item_count++; + formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size); } } @@ -944,59 +935,60 @@ formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems) share a common enum with the compiler. */ void -transfer_integer (void *p, int kind) +transfer_integer (st_parameter_dt *dtp, void *p, int kind) { - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - transfer (BT_INTEGER, p, kind, kind, 1); + dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1); } void -transfer_real (void *p, int kind) +transfer_real (st_parameter_dt *dtp, void *p, int kind) { size_t size; - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_real_kind (kind); - transfer (BT_REAL, p, kind, size, 1); + dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1); } void -transfer_logical (void *p, int kind) +transfer_logical (st_parameter_dt *dtp, void *p, int kind) { - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - transfer (BT_LOGICAL, p, kind, kind, 1); + dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1); } void -transfer_character (void *p, int len) +transfer_character (st_parameter_dt *dtp, void *p, int len) { - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; /* Currently we support only 1 byte chars, and the library is a bit confused of character kind vs. length, so we kludge it by setting kind = length. */ - transfer (BT_CHARACTER, p, len, len, 1); + dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1); } void -transfer_complex (void *p, int kind) +transfer_complex (st_parameter_dt *dtp, void *p, int kind) { size_t size; - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; size = size_from_complex_kind (kind); - transfer (BT_COMPLEX, p, kind, size, 1); + dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1); } void -transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen) +transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, + gfc_charlen_type charlen) { index_type count[GFC_MAX_DIMENSIONS]; index_type extent[GFC_MAX_DIMENSIONS]; @@ -1006,7 +998,7 @@ transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen) char *data; bt iotype; - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; type = GFC_DESCRIPTOR_TYPE (desc); @@ -1042,10 +1034,11 @@ transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen) kind = charlen; break; case GFC_DTYPE_DERIVED: - internal_error ("Derived type I/O should have been handled via the frontend."); + internal_error (&dtp->common, + "Derived type I/O should have been handled via the frontend."); break; default: - internal_error ("transfer_array(): Bad type"); + internal_error (&dtp->common, "transfer_array(): Bad type"); } if (desc->dim[0].stride == 0) @@ -1077,7 +1070,7 @@ transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen) while (data) { - transfer (iotype, data, kind, size, tsize); + dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); data += stride0 * size * tsize; count[0] += tsize; n = 0; @@ -1104,26 +1097,26 @@ transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen) /* Preposition a sequential unformatted file while reading. */ static void -us_read (void) +us_read (st_parameter_dt *dtp) { char *p; int n; gfc_offset i; n = sizeof (gfc_offset); - p = salloc_r (current_unit->s, &n); + p = salloc_r (dtp->u.p.current_unit->s, &n); if (n == 0) return; /* end of file */ if (p == NULL || n != sizeof (gfc_offset)) { - generate_error (ERROR_BAD_US, NULL); + generate_error (&dtp->common, ERROR_BAD_US, NULL); return; } memcpy (&i, p, sizeof (gfc_offset)); - current_unit->bytes_left = i; + dtp->u.p.current_unit->bytes_left = i; } @@ -1131,30 +1124,30 @@ us_read (void) amount to writing a bogus length that will be filled in later. */ static void -us_write (void) +us_write (st_parameter_dt *dtp) { char *p; int length; length = sizeof (gfc_offset); - p = salloc_w (current_unit->s, &length); + p = salloc_w (dtp->u.p.current_unit->s, &length); if (p == NULL) { - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); return; } memset (p, '\0', sizeof (gfc_offset)); /* Bogus value for now. */ - if (sfree (current_unit->s) == FAILURE) - generate_error (ERROR_OS, NULL); + if (sfree (dtp->u.p.current_unit->s) == FAILURE) + generate_error (&dtp->common, ERROR_OS, NULL); /* For sequential unformatted, we write until we have more bytes than can fit in the record markers. If disk space runs out first, it will error on the write. */ - current_unit->recl = g.max_offset; + dtp->u.p.current_unit->recl = max_offset; - current_unit->bytes_left = current_unit->recl; + dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } @@ -1163,29 +1156,29 @@ us_write (void) record. */ static void -pre_position (void) +pre_position (st_parameter_dt *dtp) { - if (current_unit->current_record) + if (dtp->u.p.current_unit->current_record) return; /* Already positioned. */ - switch (current_mode ()) + switch (current_mode (dtp)) { case UNFORMATTED_SEQUENTIAL: - if (g.mode == READING) - us_read (); + if (dtp->u.p.mode == READING) + us_read (dtp); else - us_write (); + us_write (dtp); break; case FORMATTED_SEQUENTIAL: case FORMATTED_DIRECT: case UNFORMATTED_DIRECT: - current_unit->bytes_left = current_unit->recl; + dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; break; } - current_unit->current_record = 1; + dtp->u.p.current_unit->current_record = 1; } @@ -1193,29 +1186,37 @@ pre_position (void) both reading and writing. */ static void -data_transfer_init (int read_flag) +data_transfer_init (st_parameter_dt *dtp, int read_flag) { unit_flags u_flags; /* Used for creating a unit if needed. */ + GFC_INTEGER_4 cf = dtp->common.flags; + namelist_info *ionml; - g.mode = read_flag ? READING : WRITING; + ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL; + memset (&dtp->u.p, 0, sizeof (dtp->u.p)); + dtp->u.p.ionml = ionml; + dtp->u.p.mode = read_flag ? READING : WRITING; - if (ioparm.size != NULL) - *ioparm.size = 0; /* Initialize the count. */ + if ((cf & IOPARM_DT_HAS_SIZE) != 0) + *dtp->size = 0; /* Initialize the count. */ - current_unit = get_unit (read_flag); - if (current_unit == NULL) + dtp->u.p.current_unit = get_unit (dtp, 1); + if (dtp->u.p.current_unit->s == NULL) { /* Open the unit with some default flags. */ - if (ioparm.unit < 0) + st_parameter_open opp; + if (dtp->common.unit < 0) { - generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement"); - library_end (); + close_unit (dtp->u.p.current_unit); + dtp->u.p.current_unit = NULL; + generate_error (&dtp->common, ERROR_BAD_OPTION, + "Bad unit number in OPEN statement"); return; } memset (&u_flags, '\0', sizeof (u_flags)); u_flags.access = ACCESS_SEQUENTIAL; u_flags.action = ACTION_READWRITE; /* Is it unformatted? */ - if (ioparm.format == NULL && !ioparm.list_format) + if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) u_flags.form = FORM_UNFORMATTED; else u_flags.form = FORM_UNSPECIFIED; @@ -1223,214 +1224,219 @@ data_transfer_init (int read_flag) u_flags.blank = BLANK_UNSPECIFIED; u_flags.pad = PAD_UNSPECIFIED; u_flags.status = STATUS_UNKNOWN; - new_unit(&u_flags); - current_unit = get_unit (read_flag); + opp.common = dtp->common; + opp.common.flags &= IOPARM_COMMON_MASK; + dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); + dtp->common.flags &= ~IOPARM_COMMON_MASK; + dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); + if (dtp->u.p.current_unit == NULL) + return; } - if (current_unit == NULL) - return; - /* Check the action. */ - if (read_flag && current_unit->flags.action == ACTION_WRITE) - generate_error (ERROR_BAD_ACTION, + if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) + generate_error (&dtp->common, ERROR_BAD_ACTION, "Cannot read from file opened for WRITE"); - if (!read_flag && current_unit->flags.action == ACTION_READ) - generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ"); + if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) + generate_error (&dtp->common, ERROR_BAD_ACTION, + "Cannot write to file opened for READ"); - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; + dtp->u.p.first_item = 1; + /* Check the format. */ - if (ioparm.format) - parse_format (); + if ((cf & IOPARM_DT_HAS_FORMAT) != 0) + parse_format (dtp); - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - if (current_unit->flags.form == FORM_UNFORMATTED - && (ioparm.format != NULL || ioparm.list_format)) - generate_error (ERROR_OPTION_CONFLICT, + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED + && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) + != 0) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "Format present for UNFORMATTED data transfer"); - if (ioparm.namelist_name != NULL && ionml != NULL) + if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) { - if(ioparm.format != NULL) - generate_error (ERROR_OPTION_CONFLICT, + if ((cf & IOPARM_DT_HAS_FORMAT) != 0) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "A format cannot be specified with a namelist"); } - else if (current_unit->flags.form == FORM_FORMATTED && - ioparm.format == NULL && !ioparm.list_format) - generate_error (ERROR_OPTION_CONFLICT, + else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && + !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "Missing format for FORMATTED data transfer"); - if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED) - generate_error (ERROR_OPTION_CONFLICT, + if (is_internal_unit (dtp) + && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "Internal file cannot be accessed by UNFORMATTED data transfer"); /* Check the record number. */ - if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0) + if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT + && (cf & IOPARM_DT_HAS_REC) == 0) { - generate_error (ERROR_MISSING_OPTION, + generate_error (&dtp->common, ERROR_MISSING_OPTION, "Direct access data transfer requires record number"); return; } - if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0) + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL + && (cf & IOPARM_DT_HAS_REC) != 0) { - generate_error (ERROR_OPTION_CONFLICT, + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "Record number not allowed for sequential access data transfer"); return; } /* Process the ADVANCE option. */ - advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED : - find_option (ioparm.advance, ioparm.advance_len, advance_opt, - "Bad ADVANCE parameter in data transfer statement"); + dtp->u.p.advance_status + = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED : + find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt, + "Bad ADVANCE parameter in data transfer statement"); - if (advance_status != ADVANCE_UNSPECIFIED) + if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED) { - if (current_unit->flags.access == ACCESS_DIRECT) - generate_error (ERROR_OPTION_CONFLICT, + if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with sequential access"); - if (is_internal_unit ()) - generate_error (ERROR_OPTION_CONFLICT, + if (is_internal_unit (dtp)) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "ADVANCE specification conflicts with internal file"); - if (ioparm.format == NULL || ioparm.list_format) - generate_error (ERROR_OPTION_CONFLICT, + if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) + != IOPARM_DT_HAS_FORMAT) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "ADVANCE specification requires an explicit format"); } if (read_flag) { - if (ioparm.eor != 0 && advance_status != ADVANCE_NO) - generate_error (ERROR_MISSING_OPTION, + if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) + generate_error (&dtp->common, ERROR_MISSING_OPTION, "EOR specification requires an ADVANCE specification of NO"); - if (ioparm.size != NULL && advance_status != ADVANCE_NO) - generate_error (ERROR_MISSING_OPTION, + if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) + generate_error (&dtp->common, ERROR_MISSING_OPTION, "SIZE specification requires an ADVANCE specification of NO"); } else { /* Write constraints. */ - if (ioparm.end != 0) - generate_error (ERROR_OPTION_CONFLICT, + if ((cf & IOPARM_END) != 0) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "END specification cannot appear in a write statement"); - if (ioparm.eor != 0) - generate_error (ERROR_OPTION_CONFLICT, + if ((cf & IOPARM_EOR) != 0) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "EOR specification cannot appear in a write statement"); - if (ioparm.size != 0) - generate_error (ERROR_OPTION_CONFLICT, + if ((cf & IOPARM_DT_HAS_SIZE) != 0) + generate_error (&dtp->common, ERROR_OPTION_CONFLICT, "SIZE specification cannot appear in a write statement"); } - if (advance_status == ADVANCE_UNSPECIFIED) - advance_status = ADVANCE_YES; - if (ioparm.library_return != LIBRARY_OK) + if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) + dtp->u.p.advance_status = ADVANCE_YES; + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; /* Sanity checks on the record number. */ - if (ioparm.rec) + if ((cf & IOPARM_DT_HAS_REC) != 0) { - if (ioparm.rec <= 0) + if (dtp->rec <= 0) { - generate_error (ERROR_BAD_OPTION, "Record number must be positive"); + generate_error (&dtp->common, ERROR_BAD_OPTION, + "Record number must be positive"); return; } - if (ioparm.rec >= current_unit->maxrec) + if (dtp->rec >= dtp->u.p.current_unit->maxrec) { - generate_error (ERROR_BAD_OPTION, "Record number too large"); + generate_error (&dtp->common, ERROR_BAD_OPTION, + "Record number too large"); return; } /* Check to see if we might be reading what we wrote before */ - if (g.mode == READING && current_unit->mode == WRITING) - flush(current_unit->s); + if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING) + flush(dtp->u.p.current_unit->s); /* Check whether the record exists to be read. Only a partial record needs to exist. */ - if (g.mode == READING && (ioparm.rec -1) - * current_unit->recl >= file_length (current_unit->s)) + if (dtp->u.p.mode == READING && (dtp->rec -1) + * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s)) { - generate_error (ERROR_BAD_OPTION, "Non-existing record number"); + generate_error (&dtp->common, ERROR_BAD_OPTION, + "Non-existing record number"); return; } /* Position the file. */ - if (sseek (current_unit->s, - (ioparm.rec - 1) * current_unit->recl) == FAILURE) + if (sseek (dtp->u.p.current_unit->s, + (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE) { - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); return; } } /* Overwriting an existing sequential file ? it is always safe to truncate the file on the first write */ - if (g.mode == WRITING - && current_unit->flags.access == ACCESS_SEQUENTIAL - && current_unit->last_record == 0 && !is_preconnected(current_unit->s)) - struncate(current_unit->s); + 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(current_unit->s); + flush_if_preconnected(dtp->u.p.current_unit->s); - current_unit->mode = g.mode; + dtp->u.p.current_unit->mode = dtp->u.p.mode; /* Set the initial value of flags. */ - g.blank_status = current_unit->flags.blank; - g.sign_status = SIGN_S; - g.scale_factor = 0; - g.seen_dollar = 0; - g.first_item = 1; - g.item_count = 0; - sf_seen_eor = 0; - eor_condition = 0; + dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; + dtp->u.p.sign_status = SIGN_S; - pre_position (); + pre_position (dtp); /* Set up the subroutine that will handle the transfers. */ if (read_flag) { - if (current_unit->flags.form == FORM_UNFORMATTED) - transfer = unformatted_read; + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) + dtp->u.p.transfer = unformatted_read; else { - if (ioparm.list_format) - { - transfer = list_formatted_read; - init_at_eol(); - } + if ((cf & IOPARM_DT_LIST_FORMAT) != 0) + dtp->u.p.transfer = list_formatted_read; else - transfer = formatted_transfer; + dtp->u.p.transfer = formatted_transfer; } } else { - if (current_unit->flags.form == FORM_UNFORMATTED) - transfer = unformatted_write; + if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) + dtp->u.p.transfer = unformatted_write; else { - if (ioparm.list_format) - transfer = list_formatted_write; + if ((cf & IOPARM_DT_LIST_FORMAT) != 0) + dtp->u.p.transfer = list_formatted_write; else - transfer = formatted_transfer; + dtp->u.p.transfer = formatted_transfer; } } @@ -1438,26 +1444,24 @@ data_transfer_init (int read_flag) if (read_flag) { - if (current_unit->read_bad) + if (dtp->u.p.current_unit->read_bad) { - generate_error (ERROR_BAD_OPTION, + generate_error (&dtp->common, ERROR_BAD_OPTION, "Cannot READ after a nonadvancing WRITE"); return; } } else { - if (advance_status == ADVANCE_YES && !g.seen_dollar) - current_unit->read_bad = 1; + if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar) + dtp->u.p.current_unit->read_bad = 1; } - /* Reset counters for T and X-editing. */ - max_pos = skips = pending_spaces = 0; - /* Start the data transfer if we are doing a formatted transfer. */ - if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format - && ioparm.namelist_name == NULL && ionml == NULL) - formatted_transfer (0, NULL, 0, 0, 1); + if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED + && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0) + && dtp->u.p.ionml == NULL) + formatted_transfer (dtp, 0, NULL, 0, 0, 1); } /* Initialize an array_loop_spec given the array descriptor. The function @@ -1489,7 +1493,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls) negative strides. */ gfc_offset -next_array_record ( array_loop_spec * ls ) +next_array_record (st_parameter_dt *dtp, array_loop_spec *ls) { int i, carry; gfc_offset index; @@ -1497,7 +1501,7 @@ next_array_record ( array_loop_spec * ls ) carry = 1; index = 0; - for (i = 0; i < current_unit->rank; i++) + for (i = 0; i < dtp->u.p.current_unit->rank; i++) { if (carry) { @@ -1522,49 +1526,49 @@ next_array_record ( array_loop_spec * ls ) #define MAX_READ 4096 static void -next_record_r (void) +next_record_r (st_parameter_dt *dtp) { gfc_offset new, record; int bytes_left, rlength, length; char *p; - switch (current_mode ()) + switch (current_mode (dtp)) { case UNFORMATTED_SEQUENTIAL: - current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */ + dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */ /* Fall through... */ case FORMATTED_DIRECT: case UNFORMATTED_DIRECT: - if (current_unit->bytes_left == 0) + if (dtp->u.p.current_unit->bytes_left == 0) break; - if (is_seekable (current_unit->s)) + if (is_seekable (dtp->u.p.current_unit->s)) { - new = file_position (current_unit->s) + current_unit->bytes_left; + new = file_position (dtp->u.p.current_unit->s) + dtp->u.p.current_unit->bytes_left; /* Direct access files do not generate END conditions, only I/O errors. */ - if (sseek (current_unit->s, new) == FAILURE) - generate_error (ERROR_OS, NULL); + if (sseek (dtp->u.p.current_unit->s, new) == FAILURE) + generate_error (&dtp->common, ERROR_OS, NULL); } else { /* Seek by reading data. */ - while (current_unit->bytes_left > 0) + while (dtp->u.p.current_unit->bytes_left > 0) { - rlength = length = (MAX_READ > current_unit->bytes_left) ? - MAX_READ : current_unit->bytes_left; + rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ? + MAX_READ : dtp->u.p.current_unit->bytes_left; - p = salloc_r (current_unit->s, &rlength); + p = salloc_r (dtp->u.p.current_unit->s, &rlength); if (p == NULL) { - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); break; } - current_unit->bytes_left -= length; + dtp->u.p.current_unit->bytes_left -= length; } } break; @@ -1572,49 +1576,50 @@ next_record_r (void) case FORMATTED_SEQUENTIAL: length = 1; /* sf_read has already terminated input because of an '\n' */ - if (sf_seen_eor) + if (dtp->u.p.sf_seen_eor) { - sf_seen_eor=0; + dtp->u.p.sf_seen_eor = 0; break; } - if (is_internal_unit()) + if (is_internal_unit (dtp)) { - if (is_array_io()) - { - record = next_array_record (current_unit->ls); - - /* Now seek to this record. */ - record = record * current_unit->recl; - if (sseek (current_unit->s, record) == FAILURE) - { - generate_error (ERROR_OS, NULL); - break; - } - current_unit->bytes_left = current_unit->recl; - } - else - { - bytes_left = (int) current_unit->bytes_left; - p = salloc_r (current_unit->s, &bytes_left); - if (p != NULL) - current_unit->bytes_left = current_unit->recl; - } - break; + if (is_array_io (dtp)) + { + record = next_array_record (dtp, dtp->u.p.current_unit->ls); + + /* Now seek to this record. */ + record = record * dtp->u.p.current_unit->recl; + if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) + { + generate_error (&dtp->common, ERROR_OS, NULL); + break; + } + dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; + } + else + { + bytes_left = (int) dtp->u.p.current_unit->bytes_left; + p = salloc_r (dtp->u.p.current_unit->s, &bytes_left); + if (p != NULL) + dtp->u.p.current_unit->bytes_left + = dtp->u.p.current_unit->recl; + } + break; } else do { - p = salloc_r (current_unit->s, &length); + p = salloc_r (dtp->u.p.current_unit->s, &length); if (p == NULL) { - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); break; } if (length == 0) { - current_unit->endfile = AT_ENDFILE; + dtp->u.p.current_unit->endfile = AT_ENDFILE; break; } } @@ -1623,116 +1628,117 @@ next_record_r (void) break; } - if (current_unit->flags.access == ACCESS_SEQUENTIAL) - test_endfile (current_unit); + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + test_endfile (dtp->u.p.current_unit); } /* Position to the next record in write mode. */ static void -next_record_w (void) +next_record_w (st_parameter_dt *dtp) { gfc_offset c, m, record; int bytes_left, length; char *p; /* Zero counters for X- and T-editing. */ - max_pos = skips = pending_spaces = 0; + dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; - switch (current_mode ()) + switch (current_mode (dtp)) { case FORMATTED_DIRECT: - if (current_unit->bytes_left == 0) + if (dtp->u.p.current_unit->bytes_left == 0) break; - length = current_unit->bytes_left; - p = salloc_w (current_unit->s, &length); + length = dtp->u.p.current_unit->bytes_left; + p = salloc_w (dtp->u.p.current_unit->s, &length); if (p == NULL) goto io_error; - memset (p, ' ', current_unit->bytes_left); - if (sfree (current_unit->s) == FAILURE) + memset (p, ' ', dtp->u.p.current_unit->bytes_left); + if (sfree (dtp->u.p.current_unit->s) == FAILURE) goto io_error; break; case UNFORMATTED_DIRECT: - if (sfree (current_unit->s) == FAILURE) + if (sfree (dtp->u.p.current_unit->s) == FAILURE) goto io_error; break; case UNFORMATTED_SEQUENTIAL: - m = current_unit->recl - current_unit->bytes_left; /* Bytes written. */ - c = file_position (current_unit->s); + /* Bytes written. */ + m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left; + c = file_position (dtp->u.p.current_unit->s); length = sizeof (gfc_offset); /* Write the length tail. */ - p = salloc_w (current_unit->s, &length); + p = salloc_w (dtp->u.p.current_unit->s, &length); if (p == NULL) goto io_error; memcpy (p, &m, sizeof (gfc_offset)); - if (sfree (current_unit->s) == FAILURE) + if (sfree (dtp->u.p.current_unit->s) == FAILURE) goto io_error; /* Seek to the head and overwrite the bogus length with the real length. */ - p = salloc_w_at (current_unit->s, &length, c - m - length); + p = salloc_w_at (dtp->u.p.current_unit->s, &length, c - m - length); if (p == NULL) - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); memcpy (p, &m, sizeof (gfc_offset)); - if (sfree (current_unit->s) == FAILURE) + if (sfree (dtp->u.p.current_unit->s) == FAILURE) goto io_error; /* Seek past the end of the current record. */ - if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE) + if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE) goto io_error; break; case FORMATTED_SEQUENTIAL: - if (current_unit->bytes_left == 0) + if (dtp->u.p.current_unit->bytes_left == 0) break; - if (is_internal_unit()) + if (is_internal_unit (dtp)) { - if (is_array_io()) + if (is_array_io (dtp)) { - bytes_left = (int) current_unit->bytes_left; - p = salloc_w (current_unit->s, &bytes_left); + bytes_left = (int) dtp->u.p.current_unit->bytes_left; + p = salloc_w (dtp->u.p.current_unit->s, &bytes_left); if (p == NULL) { - generate_error (ERROR_END, NULL); + generate_error (&dtp->common, ERROR_END, NULL); return; } - memset(p, ' ', bytes_left); - - /* Now that the current record has been padded out, - determine where the next record in the array is. */ - - record = next_array_record (current_unit->ls); - - /* Now seek to this record */ - record = record * current_unit->recl; - - if (sseek (current_unit->s, record) == FAILURE) - goto io_error; - - current_unit->bytes_left = current_unit->recl; + memset(p, ' ', bytes_left); + + /* Now that the current record has been padded out, + determine where the next record in the array is. */ + + record = next_array_record (dtp, dtp->u.p.current_unit->ls); + + /* Now seek to this record */ + record = record * dtp->u.p.current_unit->recl; + + if (sseek (dtp->u.p.current_unit->s, record) == FAILURE) + goto io_error; + + dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } else { length = 1; - p = salloc_w (current_unit->s, &length); - if (p==NULL) - goto io_error; + p = salloc_w (dtp->u.p.current_unit->s, &length); + if (p == NULL) + goto io_error; } } else @@ -1742,7 +1748,7 @@ next_record_w (void) #else length = 1; #endif - p = salloc_w (current_unit->s, &length); + p = salloc_w (dtp->u.p.current_unit->s, &length); if (p) { /* No new line for internal writes. */ #ifdef HAVE_CRLF @@ -1759,7 +1765,7 @@ next_record_w (void) break; io_error: - generate_error (ERROR_OS, NULL); + generate_error (&dtp->common, ERROR_OS, NULL); break; } } @@ -1770,33 +1776,33 @@ next_record_w (void) the next record. */ void -next_record (int done) +next_record (st_parameter_dt *dtp, int done) { gfc_offset fp; /* File position. */ - current_unit->read_bad = 0; + dtp->u.p.current_unit->read_bad = 0; - if (g.mode == READING) - next_record_r (); + if (dtp->u.p.mode == READING) + next_record_r (dtp); else - next_record_w (); + next_record_w (dtp); /* keep position up to date for INQUIRE */ - current_unit->flags.position = POSITION_ASIS; + dtp->u.p.current_unit->flags.position = POSITION_ASIS; - current_unit->current_record = 0; - if (current_unit->flags.access == ACCESS_DIRECT) + dtp->u.p.current_unit->current_record = 0; + if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) { - fp = file_position (current_unit->s); + fp = file_position (dtp->u.p.current_unit->s); /* Calculate next record, rounding up partial records. */ - current_unit->last_record = (fp + current_unit->recl - 1) - / current_unit->recl; + dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1) + / dtp->u.p.current_unit->recl; } else - current_unit->last_record++; + dtp->u.p.current_unit->last_record++; if (!done) - pre_position (); + pre_position (dtp); } @@ -1805,62 +1811,64 @@ next_record (int done) stream associated with the unit. */ static void -finalize_transfer (void) +finalize_transfer (st_parameter_dt *dtp) { + jmp_buf eof_jump; + GFC_INTEGER_4 cf = dtp->common.flags; - if (eor_condition) + if (dtp->u.p.eor_condition) { - generate_error (ERROR_EOR, NULL); + generate_error (&dtp->common, ERROR_EOR, NULL); return; } - if (ioparm.library_return != LIBRARY_OK) + if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) return; - if ((ionml != NULL) && (ioparm.namelist_name != NULL)) + if ((dtp->u.p.ionml != NULL) + && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) { - if (ioparm.namelist_read_mode) - namelist_read(); + if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) + namelist_read (dtp); else - namelist_write(); + namelist_write (dtp); } - transfer = NULL; - if (current_unit == NULL) + dtp->u.p.transfer = NULL; + if (dtp->u.p.current_unit == NULL) return; - if (setjmp (g.eof_jump)) + dtp->u.p.eof_jump = &eof_jump; + if (setjmp (eof_jump)) { - generate_error (ERROR_END, NULL); + generate_error (&dtp->common, ERROR_END, NULL); return; } - if (ioparm.list_format && g.mode == READING) - finish_list_read (); + if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) + finish_list_read (dtp); else { - free_fnodes (); - - if (advance_status == ADVANCE_NO || g.seen_dollar) + if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) { /* Most systems buffer lines, so force the partial record to be written out. */ - flush (current_unit->s); - g.seen_dollar = 0; + flush (dtp->u.p.current_unit->s); + dtp->u.p.seen_dollar = 0; return; } - next_record (1); - current_unit->current_record = 0; + next_record (dtp, 1); + dtp->u.p.current_unit->current_record = 0; } - sfree (current_unit->s); + sfree (dtp->u.p.current_unit->s); - if (is_internal_unit ()) + if (is_internal_unit (dtp)) { - if (is_array_io() && current_unit->ls != NULL) - free_mem (current_unit->ls); - sclose (current_unit->s); + if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL) + free_mem (dtp->u.p.current_unit->ls); + sclose (dtp->u.p.current_unit->s); } } @@ -1869,13 +1877,13 @@ finalize_transfer (void) data transfer, it just updates the length counter. */ static void -iolength_transfer (bt type __attribute__((unused)), +iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), void *dest __attribute__ ((unused)), int kind __attribute__((unused)), size_t size, size_t nelems) { - if (ioparm.iolength != NULL) - *ioparm.iolength += (GFC_INTEGER_4) size * nelems; + if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) + *dtp->iolength += (GFC_INTEGER_4) size * nelems; } @@ -1884,16 +1892,16 @@ iolength_transfer (bt type __attribute__((unused)), doesn't have to deal with units at all. */ static void -iolength_transfer_init (void) +iolength_transfer_init (st_parameter_dt *dtp) { - if (ioparm.iolength != NULL) - *ioparm.iolength = 0; + if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) + *dtp->iolength = 0; - g.item_count = 0; + memset (&dtp->u.p, 0, sizeof (dtp->u.p)); /* Set up the subroutine that will handle the transfers. */ - transfer = iolength_transfer; + dtp->u.p.transfer = iolength_transfer; } @@ -1902,133 +1910,148 @@ iolength_transfer_init (void) it must still be a runtime library call so that we can determine the iolength for dynamic arrays and such. */ -extern void st_iolength (void); +extern void st_iolength (st_parameter_dt *); export_proto(st_iolength); void -st_iolength (void) +st_iolength (st_parameter_dt *dtp) { - library_start (); - iolength_transfer_init (); + library_start (&dtp->common); + iolength_transfer_init (dtp); } -extern void st_iolength_done (void); +extern void st_iolength_done (st_parameter_dt *); export_proto(st_iolength_done); void -st_iolength_done (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 (); } /* The READ statement. */ -extern void st_read (void); +extern void st_read (st_parameter_dt *); export_proto(st_read); void -st_read (void) +st_read (st_parameter_dt *dtp) { - library_start (); + library_start (&dtp->common); - data_transfer_init (1); + data_transfer_init (dtp, 1); /* Handle complications dealing with the endfile record. It is significant that this is the only place where ERROR_END is generated. Reading an end of file elsewhere is either end of record or an I/O error. */ - if (current_unit->flags.access == ACCESS_SEQUENTIAL) - switch (current_unit->endfile) + 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()) + if (!is_internal_unit (dtp)) { - generate_error (ERROR_END, NULL); - current_unit->endfile = AFTER_ENDFILE; - current_unit->current_record = 0; + generate_error (&dtp->common, ERROR_END, NULL); + dtp->u.p.current_unit->endfile = AFTER_ENDFILE; + dtp->u.p.current_unit->current_record = 0; } break; case AFTER_ENDFILE: - generate_error (ERROR_ENDFILE, NULL); - current_unit->current_record = 0; + generate_error (&dtp->common, ERROR_ENDFILE, NULL); + dtp->u.p.current_unit->current_record = 0; break; } } -extern void st_read_done (void); +extern void st_read_done (st_parameter_dt *); export_proto(st_read_done); void -st_read_done (void) +st_read_done (st_parameter_dt *dtp) { - finalize_transfer (); + 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); library_end (); } -extern void st_write (void); +extern void st_write (st_parameter_dt *); export_proto(st_write); void -st_write (void) +st_write (st_parameter_dt *dtp) { - - library_start (); - data_transfer_init (0); + library_start (&dtp->common); + data_transfer_init (dtp, 0); } -extern void st_write_done (void); +extern void st_write_done (st_parameter_dt *); export_proto(st_write_done); void -st_write_done (void) +st_write_done (st_parameter_dt *dtp) { - finalize_transfer (); + finalize_transfer (dtp); /* Deal with endfile conditions associated with sequential files. */ - if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL) - switch (current_unit->endfile) + if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (dtp->u.p.current_unit->endfile) { case AT_ENDFILE: /* Remain at the endfile record. */ break; case AFTER_ENDFILE: - current_unit->endfile = AT_ENDFILE; /* Just at it now. */ + dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ break; case NO_ENDFILE: - if (current_unit->current_record > current_unit->last_record) + if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record) { /* Get rid of whatever is after this record. */ - if (struncate (current_unit->s) == FAILURE) - generate_error (ERROR_OS, NULL); + if (struncate (dtp->u.p.current_unit->s) == FAILURE) + generate_error (&dtp->common, ERROR_OS, NULL); } - current_unit->endfile = AT_ENDFILE; + 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); library_end (); } /* Receives the scalar information for namelist objects and stores it in a linked list of namelist_info types. */ -extern void st_set_nml_var (void * ,char * , - GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4); +extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, + GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); export_proto(st_set_nml_var); void -st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len, - gfc_charlen_type string_length, GFC_INTEGER_4 dtype) +st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, + GFC_INTEGER_4 len, gfc_charlen_type string_length, + GFC_INTEGER_4 dtype) { namelist_info *t1 = NULL; namelist_info *nml; @@ -2062,31 +2085,35 @@ st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len, nml->next = NULL; - if (ionml == NULL) - ionml = nml; + if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0) + { + dtp->common.flags |= IOPARM_DT_IONML_SET; + dtp->u.p.ionml = nml; + } else { - for (t1 = ionml; t1->next; t1 = t1->next); + for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next); t1->next = nml; } - return; } /* Store the dimensional information for the namelist object. */ -extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4, - GFC_INTEGER_4 ,GFC_INTEGER_4); +extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, + GFC_INTEGER_4, GFC_INTEGER_4, + GFC_INTEGER_4); export_proto(st_set_nml_var_dim); void -st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride, - GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound) +st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim, + GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound, + GFC_INTEGER_4 ubound) { namelist_info * nml; int n; n = (int)n_dim; - for (nml = ionml; nml->next; nml = nml->next); + for (nml = dtp->u.p.ionml; nml->next; nml = nml->next); nml->dim[n].stride = (ssize_t)stride; nml->dim[n].lbound = (ssize_t)lbound; |