diff options
Diffstat (limited to 'libgfortran/io')
| -rw-r--r-- | libgfortran/io/format.c | 87 | ||||
| -rw-r--r-- | libgfortran/io/format.h | 10 | ||||
| -rw-r--r-- | libgfortran/io/io.h | 50 | ||||
| -rw-r--r-- | libgfortran/io/list_read.c | 99 | ||||
| -rw-r--r-- | libgfortran/io/transfer.c | 457 | ||||
| -rw-r--r-- | libgfortran/io/unit.c | 32 | ||||
| -rw-r--r-- | libgfortran/io/unix.c | 2 | ||||
| -rw-r--r-- | libgfortran/io/write.c | 158 |
8 files changed, 722 insertions, 173 deletions
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index dd05b7a..31bc642 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -70,7 +70,7 @@ free_format_hash_table (gfc_unit *u) free (u->format_hash_table[i].key); } u->format_hash_table[i].key = NULL; - u->format_hash_table[i].key_len = 0; + u->format_hash_table[i].key_len = 0; u->format_hash_table[i].hashed_fmt = NULL; } } @@ -84,7 +84,7 @@ reset_node (fnode *fn) fn->count = 0; fn->current = NULL; - + if (fn->format != FMT_LPAREN) return; @@ -261,11 +261,20 @@ void free_format_data (format_data *fmt) { fnode_array *fa, *fa_next; - + fnode *fnp; if (fmt == NULL) return; + /* Free vlist descriptors in the fnode_array if one was allocated. */ + for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++) + if (fnp->format == FMT_DT) + { + if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist)) + free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist)); + free (fnp->u.udf.vlist); + } + for (fa = fmt->array.next; fa; fa = fa_next) { fa_next = fa->next; @@ -545,6 +554,9 @@ format_lex (format_data *fmt) case 'C': token = FMT_DC; break; + case 'T': + token = FMT_DT; + break; default: token = FMT_D; unget_char (fmt); @@ -740,7 +752,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) tail->u.string.length = fmt->value; tail->repeat = 1; goto optional_comma; - + case FMT_RC: case FMT_RD: case FMT_RN: @@ -806,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) case FMT_EN: case FMT_ES: case FMT_D: + case FMT_DT: case FMT_L: case FMT_A: case FMT_F: @@ -849,6 +862,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) /* In this state, t must currently be a data descriptor. Deal with things that can/must follow the descriptor */ data_desc: + switch (t) { case FMT_L: @@ -997,7 +1011,57 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) } break; + case FMT_DT: + *seen_dd = true; + get_fnode (fmt, &head, &tail, t); + tail->repeat = repeat; + + t = format_lex (fmt); + + /* Initialize the vlist to a zero size array. */ + tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4)); + GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL; + GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0); + if (t == FMT_STRING) + { + /* Get pointer to the optional format string. */ + tail->u.udf.string = fmt->string; + tail->u.udf.string_len = fmt->value; + t = format_lex (fmt); + } + if (t == FMT_LPAREN) + { + /* Temporary buffer to hold the vlist values. */ + GFC_INTEGER_4 temp[FARRAY_SIZE]; + int i = 0; + loop: + t = format_lex (fmt); + if (t != FMT_POSINT) + { + fmt->error = posint_required; + goto finished; + } + /* Save the positive integer value. */ + temp[i++] = fmt->value; + t = format_lex (fmt); + if (t == FMT_COMMA) + goto loop; + if (t == FMT_RPAREN) + { + /* We have parsed the complete vlist so initialize the + array descriptor and save it in the format node. */ + gfc_array_i4 *vp = tail->u.udf.vlist; + GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4)); + GFC_DIMENSION_SET(vp->dim[0],1, i, 1); + memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4)); + break; + } + fmt->error = unexpected_element; + goto finished; + } + fmt->saved_token = t; + break; case FMT_H: if (repeat > fmt->format_string_len) { @@ -1219,9 +1283,12 @@ parse_format (st_parameter_dt *dtp) format_data *fmt; bool format_cache_ok, seen_data_desc = false; - /* Don't cache for internal units and set an arbitrary limit on the size of - format strings we will cache. (Avoids memory issues.) */ - format_cache_ok = !is_internal_unit (dtp); + /* Don't cache for internal units and set an arbitrary limit on the + size of format strings we will cache. (Avoids memory issues.) + Also, the format_hash_table resides in the current_unit, so + child_dtio procedures would overwrite the parent table */ + format_cache_ok = !is_internal_unit (dtp) + && (dtp->u.p.current_unit->child_dtio == 0); /* Lookup format string to see if it has already been parsed. */ if (format_cache_ok) @@ -1257,6 +1324,10 @@ parse_format (st_parameter_dt *dtp) fmt->reversion_ok = 0; fmt->saved_format = NULL; + /* Initialize the fnode_array. */ + + memset (&(fmt->array), 0, sizeof(fmt->array)); + /* Allocate the first format node as the root of the tree. */ fmt->last = &fmt->array; @@ -1392,7 +1463,7 @@ next_format (st_parameter_dt *dtp) if (!fmt->reversion_ok && (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_A || t == FMT_D || t == FMT_DT)) fmt->reversion_ok = 1; return f; } diff --git a/libgfortran/io/format.h b/libgfortran/io/format.h index 7c81df5..3a63e53 100644 --- a/libgfortran/io/format.h +++ b/libgfortran/io/format.h @@ -38,7 +38,7 @@ typedef enum FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F, FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC, - FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ + FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT } format_token; @@ -74,6 +74,14 @@ struct fnode } integer; + struct + { + char *string; + int string_len; + gfc_array_i4 *vlist; + } + udf; /* User Defined Format. */ + int w; int k; int r; diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 494459f..ff75741 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -94,6 +94,30 @@ typedef struct array_loop_spec } array_loop_spec; +/* User defined input/output iomsg length. */ + +#define IOMSG_LEN 256 + +/* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat, + iomsg, (_iotype), (_iomsg)) */ +typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, gfc_array_i4 *, + GFC_INTEGER_4 *, char *, + gfc_charlen_type, gfc_charlen_type); + +/* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */ +typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *, + char *, gfc_charlen_type); + +/* The dtio calls for namelist require a CLASS object to be built. */ +typedef struct gfc_class +{ + void *data; + void *vptr; + index_type len; +} +gfc_class; + + /* A structure to build a hash table for format data. */ #define FORMAT_HASH_SIZE 16 @@ -136,6 +160,12 @@ typedef struct namelist_type /* Address for the start of the object's data. */ void * mem_pos; + /* Address of specific DTIO subroutine. */ + void * dtio_sub; + + /* Address of vtable if dtio_sub non-null. */ + void * vtable; + /* Flag to show that a read is to be attempted for this node. */ int touched; @@ -462,7 +492,7 @@ typedef struct st_parameter_dt /* Used for ungetc() style functionality. Possible values are an unsigned char, EOF, or EOF - 1 used to mark the field as not valid. */ - int last_char; + int last_char; /* No longer used, moved to gfc_unit. */ char nml_delim; int repeat_count; @@ -484,6 +514,8 @@ typedef struct st_parameter_dt largest kind. */ char value[32]; GFC_IO_INT size_used; + formatted_dtio fdtio_ptr; + unformatted_dtio ufdtio_ptr; } p; /* This pad size must be equal to the pad_size declared in trans-io.c (gfc_build_io_library_fndecls). The above structure @@ -607,6 +639,10 @@ typedef struct gfc_unit /* Function pointer, points to list_read worker functions. */ int (*next_char_fn_ptr) (st_parameter_dt *); void (*push_char_fn_ptr) (st_parameter_dt *, int); + + /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ + int child_dtio; + int last_char; } gfc_unit; @@ -728,6 +764,12 @@ internal_proto(read_radix); extern void read_decimal (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_decimal); +extern void read_user_defined (st_parameter_dt *, void *); +internal_proto(read_user_defined); + +extern void read_user_defined (st_parameter_dt *, void *); +internal_proto(read_user_defined); + /* list_read.c */ extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t, @@ -790,6 +832,12 @@ internal_proto(write_x); extern void write_z (st_parameter_dt *, const fnode *, const char *, int); internal_proto(write_z); +extern void write_user_defined (st_parameter_dt *, void *); +internal_proto(write_user_defined); + +extern void write_user_defined (st_parameter_dt *, void *); +internal_proto(write_user_defined); + extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t, size_t); internal_proto(list_formatted_write); diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 244430d..a42f12b 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -84,7 +84,7 @@ push_char_default (st_parameter_dt *dtp, int c) if (dtp->u.p.saved_string == NULL) { - // Plain malloc should suffice here, zeroing not needed? + /* Plain malloc should suffice here, zeroing not needed? */ dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1); dtp->u.p.saved_length = SCRATCH_SIZE; dtp->u.p.saved_used = 0; @@ -170,11 +170,11 @@ check_buffers (st_parameter_dt *dtp) int c; c = '\0'; - if (dtp->u.p.last_char != EOF - 1) + if (dtp->u.p.current_unit->last_char != EOF - 1) { dtp->u.p.at_eol = 0; - c = dtp->u.p.last_char; - dtp->u.p.last_char = EOF - 1; + c = dtp->u.p.current_unit->last_char; + dtp->u.p.current_unit->last_char = EOF - 1; goto done; } @@ -369,7 +369,7 @@ utf_done: static void unget_char (st_parameter_dt *dtp, int c) { - dtp->u.p.last_char = c; + dtp->u.p.current_unit->last_char = c; } @@ -385,7 +385,7 @@ eat_spaces (st_parameter_dt *dtp) This is an optimization unique to character arrays with large character lengths (PR38199). This code eliminates numerous calls to next_character. */ - if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1)) + if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1)) { gfc_offset offset = stell (dtp->u.p.current_unit->s); gfc_offset i; @@ -2167,6 +2167,46 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, if (dtp->u.p.repeat_count > 0) memcpy (dtp->u.p.value, p, size); break; + case BT_CLASS: + { + int unit = dtp->u.p.current_unit->unit_number; + char iotype[] = "LISTDIRECTED"; + gfc_charlen_type iotype_len = 12; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + gfc_array_i4 vlist; + + GFC_DESCRIPTOR_DATA(&vlist) = NULL; + GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsge, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined formatted READ procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + } + break; default: internal_error (&dtp->common, "Bad type for list read"); } @@ -3206,6 +3246,53 @@ get_name: goto nml_err_ret; } + else if (nl->dtio_sub != NULL) + { + int unit = dtp->u.p.current_unit->unit_number; + char iotype[] = "NAMELIST"; + gfc_charlen_type iotype_len = 8; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + gfc_array_i4 vlist; + gfc_class list_obj; + formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub; + + GFC_DESCRIPTOR_DATA(&vlist) = NULL; + GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + + list_obj.data = (void *)nl->mem_pos; + list_obj.vptr = nl->vtable; + list_obj.len = 0; + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined formatted READ procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + + return true; + } /* Get the length, data length, base pointer and rank of the variable. Set the default loop specification first. */ diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 4da0606..98072d0 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -57,7 +57,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see transfer_complex transfer_real128 transfer_complex128 - + and for WRITE transfer_integer_write @@ -122,6 +122,15 @@ extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int, gfc_charlen_type); export_proto(transfer_array_write); +/* User defined derived type input/output. */ +extern void +transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc); +export_proto(transfer_derived); + +extern void +transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc); +export_proto(transfer_derived_write); + static void us_read (st_parameter_dt *, int); static void us_write (st_parameter_dt *, int); static void next_record_r_unf (st_parameter_dt *, int); @@ -315,7 +324,7 @@ read_sf (st_parameter_dt *dtp, int * length) the rest of the I/O statement. Set the corresponding flag. */ if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) dtp->u.p.eor_condition = 1; - + /* If we encounter a CR, it might be a CRLF. */ if (q == '\r') /* Probably a CRLF */ { @@ -548,7 +557,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) if (is_stream_io (dtp)) { - have_read_record = sread (dtp->u.p.current_unit->s, buf, + have_read_record = sread (dtp->u.p.current_unit->s, buf, nbytes); if (unlikely (have_read_record < 0)) { @@ -556,7 +565,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) return; } - dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; + dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; if (unlikely ((ssize_t) nbytes != have_read_record)) { @@ -590,7 +599,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) return; } - if (to_read_record != (ssize_t) 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. */ @@ -639,7 +648,7 @@ 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 = sread (dtp->u.p.current_unit->s, + have_read_subrecord = sread (dtp->u.p.current_unit->s, buf + have_read_record, to_read_subrecord); if (unlikely (have_read_subrecord < 0)) { @@ -760,7 +769,7 @@ write_block (st_parameter_dt *dtp, int length) return NULL; } } - + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) dtp->u.p.size_used += (GFC_IO_INT) length; @@ -793,7 +802,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) return false; } - dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; + dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; return true; } @@ -811,7 +820,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) if (buf == NULL && nbytes == 0) return true; - have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); + have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); if (unlikely (have_written < 0)) { generate_error (&dtp->common, LIBERROR_OS, NULL); @@ -849,7 +858,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) dtp->u.p.current_unit->bytes_left_subrecord -= (gfc_offset) to_write_subrecord; - to_write_subrecord = swrite (dtp->u.p.current_unit->s, + to_write_subrecord = swrite (dtp->u.p.current_unit->s, buf + have_written, to_write_subrecord); if (unlikely (to_write_subrecord < 0)) { @@ -857,7 +866,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) return false; } - dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; + dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; nbytes -= to_write_subrecord; have_written += to_write_subrecord; @@ -903,7 +912,7 @@ reverse_memcpy (void *dest, const void *src, size_t n) static void bswap_array (void *dest, const void *src, size_t size, size_t nelems) { - const char *ps; + const char *ps; char *pd; switch (size) @@ -988,6 +997,40 @@ static void unformatted_read (st_parameter_dt *dtp, bt type, void *dest, int kind, size_t size, size_t nelems) { + if (type == BT_CLASS) + { + int unit = dtp->u.p.current_unit->unit_number; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined unformatted READ procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg, + child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + return; + } + if (type == BT_CHARACTER) size *= GFC_SIZE_OF_CHAR_KIND(kind); read_block_direct (dtp, dest, size * nelems); @@ -1016,13 +1059,47 @@ unformatted_read (st_parameter_dt *dtp, bt type, /* Master function for unformatted writes. NOTE: For kind=10 the size is 16 bytes on 64 bit machines. The unused bytes are not initialized and never used, which can show an error with memory checking analyzers like - valgrind. */ + valgrind. We us BT_CLASS to denote a User Defined I/O call. */ static void unformatted_write (st_parameter_dt *dtp, bt type, void *source, int kind, size_t size, size_t nelems) { - if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) + if (type == BT_CLASS) + { + int unit = dtp->u.p.current_unit->unit_number; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined unformatted WRITE procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg, + child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + return; + } + + if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) || kind == 1) { size_t stride = type == BT_CHARACTER ? @@ -1045,13 +1122,13 @@ unformatted_write (st_parameter_dt *dtp, bt type, nelems *= size; size = kind; } - + /* Break up complex into its constituent reals. */ if (type == BT_COMPLEX) { nelems *= 2; size /= 2; - } + } /* By now, all complex variables have been split into their constituent reals. */ @@ -1099,6 +1176,9 @@ type_name (bt type) case BT_COMPLEX: p = "COMPLEX"; break; + case BT_CLASS: + p = "CLASS or DERIVED"; + break; default: internal_error (NULL, "type_name(): Bad type"); } @@ -1115,7 +1195,7 @@ static void write_constant_string (st_parameter_dt *dtp, const fnode *f) { char c, delimiter, *p, *q; - int length; + int length; length = f->u.string.length; if (length == 0) @@ -1124,7 +1204,7 @@ write_constant_string (st_parameter_dt *dtp, const fnode *f) p = write_block (dtp, length); if (p == NULL) return; - + q = f->u.string.p; delimiter = q[-1]; @@ -1151,7 +1231,7 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) return 0; /* Adjust item_count before emitting error message. */ - snprintf (buffer, BUFLEN, + snprintf (buffer, BUFLEN, "Expected %s for item %d in formatted transfer, got %s", type_name (expected), dtp->u.p.item_count - 1, type_name (actual)); @@ -1170,7 +1250,7 @@ require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f) return 0; /* Adjust item_count before emitting error message. */ - snprintf (buffer, BUFLEN, + snprintf (buffer, BUFLEN, "Expected numeric type for item %d in formatted transfer, got %s", dtp->u.p.item_count - 1, type_name (actual)); @@ -1273,7 +1353,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind case FMT_O: if (n == 0) - goto need_read_data; + goto need_read_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_numeric_type (dtp, type, f)) return; @@ -1322,6 +1402,65 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind read_f (dtp, f, p, kind); break; + case FMT_DT: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_CLASS, type, f)) + return; + int unit = dtp->u.p.current_unit->unit_number; + char dt[] = "DT"; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + char *iotype = f->u.udf.string; + gfc_charlen_type iotype_len = f->u.udf.string_len; + + /* Build the iotype string. */ + if (iotype_len == 0) + { + iotype_len = 2; + iotype = dt; + } + else + { + iotype_len += 2; + iotype = xmalloc (iotype_len); + iotype[0] = dt[0]; + iotype[1] = dt[1]; + memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len); + } + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined formatted READ procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + + if (f->u.udf.string_len != 0) + free (iotype); + /* Note: vlist is freed in free_format_data. */ + break; + case FMT_E: if (n == 0) goto need_read_data; @@ -1438,7 +1577,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind } if (dtp->u.p.skips < 0) { - if (is_internal_unit (dtp)) + 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); @@ -1624,13 +1763,14 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin /* Now discharge T, TR and X movements to the right. This is delayed until a data producing format to suppress trailing spaces. */ - + t = f->format; 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_L || t == FMT_A || t == FMT_D + || t == FMT_DT)) || t == FMT_STRING)) { if (dtp->u.p.skips > 0) @@ -1639,13 +1779,13 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); tmp = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); - dtp->u.p.max_pos = + dtp->u.p.max_pos = dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; dtp->u.p.skips = 0; } if (dtp->u.p.skips < 0) { - if (is_internal_unit (dtp)) + 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); @@ -1684,7 +1824,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin case FMT_O: if (n == 0) - goto need_data; + goto need_data; if (!(compile_options.allow_std & GFC_STD_GNU) && require_numeric_type (dtp, type, f)) return; @@ -1733,6 +1873,63 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin write_d (dtp, f, p, kind); break; + case FMT_DT: + if (n == 0) + goto need_data; + int unit = dtp->u.p.current_unit->unit_number; + char dt[] = "DT"; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + char *iotype = f->u.udf.string; + gfc_charlen_type iotype_len = f->u.udf.string_len; + + /* Build the iotype string. */ + if (iotype_len == 0) + { + iotype_len = 2; + iotype = dt; + } + else + { + iotype_len += 2; + iotype = xmalloc (iotype_len); + iotype[0] = dt[0]; + iotype[1] = dt[1]; + memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len); + } + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined formatted WRITE procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + + if (f->u.udf.string_len != 0) + free (iotype); + /* Note: vlist is freed in free_format_data. */ + break; + case FMT_E: if (n == 0) goto need_data; @@ -2198,6 +2395,25 @@ transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind, transfer_array (dtp, desc, kind, charlen); } + +/* User defined input/output iomsg. */ + +#define IOMSG_LEN 256 + +void +transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc) +{ + if (parent->u.p.current_unit) + { + if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED) + parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc; + else + parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc; + } + parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1); +} + + /* Preposition a sequential unformatted file while reading. */ static void @@ -2340,7 +2556,7 @@ pre_position (st_parameter_dt *dtp) was specified, we continue from where we last left off. I.e. there is nothing to do here. */ break; - + case UNFORMATTED_SEQUENTIAL: if (dtp->u.p.mode == READING) us_read (dtp, 0); @@ -2384,6 +2600,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) dtp->u.p.size_used = 0; /* Initialize the count. */ dtp->u.p.current_unit = get_unit (dtp, 1); + if (dtp->u.p.current_unit->s == NULL) { /* Open the unit with some default flags. */ st_parameter_open opp; @@ -2431,15 +2648,15 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) case GFC_CONVERT_NATIVE: case GFC_CONVERT_SWAP: break; - + case GFC_CONVERT_BIG: conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; break; - + case GFC_CONVERT_LITTLE: conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; break; - + default: internal_error (&opp.common, "Illegal value for CONVERT"); break; @@ -2542,7 +2759,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) "EOF marker, possibly use REWIND or BACKSPACE"); return; } - } /* Process the ADVANCE option. */ @@ -2589,7 +2805,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } - if ((cf & IOPARM_DT_HAS_SIZE) != 0 + if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO) { generate_error (&dtp->common, LIBERROR_MISSING_OPTION, @@ -2653,7 +2869,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED : find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt, "Bad SIGN parameter in data transfer statement"); - + if (dtp->u.p.sign_status == SIGN_UNSPECIFIED) dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign; @@ -2663,7 +2879,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt, "Bad BLANK parameter in data transfer statement"); - + if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; @@ -2703,28 +2919,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) /* 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) { /* Reset the endfile flag; if we hit EOF during reading @@ -2732,7 +2948,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) 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); @@ -2752,7 +2968,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) return; } } - + /* Sanity checks on the record number. */ if ((cf & IOPARM_DT_HAS_REC) != 0) @@ -2789,11 +3005,11 @@ 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, SEEK_SET) < 0) - { - 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 */ @@ -2822,7 +3038,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos; pre_position (dtp); - + /* Set up the subroutine that will handle the transfers. */ @@ -2834,8 +3050,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) { if ((cf & IOPARM_DT_LIST_FORMAT) != 0) { - dtp->u.p.last_char = EOF - 1; - dtp->u.p.transfer = list_formatted_read; + if (dtp->u.p.current_unit->child_dtio == 0) + dtp->u.p.current_unit->last_char = EOF - 1; + dtp->u.p.transfer = list_formatted_read; } else dtp->u.p.transfer = formatted_transfer; @@ -2896,14 +3113,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) returns the index of the last element of the array, and also returns starting record, where the first I/O goes to (necessary in case of negative strides). */ - + gfc_offset init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, gfc_offset *start_record) { int rank = GFC_DESCRIPTOR_RANK(desc); int i; - gfc_offset index; + gfc_offset index; int empty; empty = 0; @@ -2916,7 +3133,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i); ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i); ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i); - empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i) + empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i) < GFC_DESCRIPTOR_LBOUND(desc,i)); if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0) @@ -2941,13 +3158,13 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, /* Determine the index to the next record in an internal unit array by by incrementing through the array_loop_spec. */ - + gfc_offset next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) { int i, carry; gfc_offset index; - + carry = 1; index = 0; @@ -2992,13 +3209,13 @@ skip_record (st_parameter_dt *dtp, ssize_t bytes) /* Direct access files do not generate END conditions, only I/O errors. */ - if (sseek (dtp->u.p.current_unit->s, + if (sseek (dtp->u.p.current_unit->s, dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0) { /* Seeking failed, fall back to seeking by reading data. */ while (dtp->u.p.current_unit->bytes_left_subrecord > 0) { - rlength = + rlength = (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ? MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord; @@ -3066,7 +3283,7 @@ next_record_r (st_parameter_dt *dtp, int done) /* No records in unformatted STREAM I/O. */ case UNFORMATTED_STREAM: return; - + case UNFORMATTED_SEQUENTIAL: next_record_r_unf (dtp, 1); dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; @@ -3107,13 +3324,13 @@ next_record_r (st_parameter_dt *dtp, int done) } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } - else + else { bytes_left = (int) dtp->u.p.current_unit->bytes_left; - bytes_left = min_off (bytes_left, + bytes_left = min_off (bytes_left, ssize (dtp->u.p.current_unit->s) - stell (dtp->u.p.current_unit->s)); - if (sseek (dtp->u.p.current_unit->s, + if (sseek (dtp->u.p.current_unit->s, bytes_left, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); @@ -3121,16 +3338,16 @@ next_record_r (st_parameter_dt *dtp, int done) } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; - } + } break; } - else + else { do { errno = 0; cc = fbuf_getc (dtp->u.p.current_unit); - if (cc == EOF) + if (cc == EOF) { if (errno != 0) generate_error (&dtp->common, LIBERROR_OS, NULL); @@ -3144,10 +3361,10 @@ next_record_r (st_parameter_dt *dtp, int done) } break; } - + if (is_stream_io (dtp)) dtp->u.p.current_unit->strm_pos++; - + p = (char) cc; } while (p != '\n'); @@ -3240,7 +3457,7 @@ 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, - m - record_marker, + if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker, SEEK_CUR) < 0)) goto io_error; @@ -3301,7 +3518,7 @@ sset (stream * s, int c, ssize_t nbyte) return trans; bytes_left -= trans; } - + return nbyte - bytes_left; } @@ -3330,8 +3547,8 @@ next_record_w (st_parameter_dt *dtp, int done) 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) + if (sset (dtp->u.p.current_unit->s, ' ', + dtp->u.p.current_unit->bytes_left) != dtp->u.p.current_unit->bytes_left) goto io_error; @@ -3362,7 +3579,7 @@ next_record_w (st_parameter_dt *dtp, int done) int finished; length = (int) dtp->u.p.current_unit->bytes_left; - + /* If the farthest position reached is greater than current position, adjust the position and set length to pad out whats left. Otherwise just pad whats left. @@ -3372,7 +3589,7 @@ next_record_w (st_parameter_dt *dtp, int done) if (max_pos > m) { length = (int) (max_pos - m); - if (sseek (dtp->u.p.current_unit->s, + if (sseek (dtp->u.p.current_unit->s, length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); @@ -3399,7 +3616,7 @@ next_record_w (st_parameter_dt *dtp, int done) &finished); if (finished) dtp->u.p.current_unit->endfile = AT_ENDFILE; - + /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; @@ -3425,7 +3642,7 @@ next_record_w (st_parameter_dt *dtp, int done) if (max_pos > m) { length = (int) (max_pos - m); - if (sseek (dtp->u.p.current_unit->s, + if (sseek (dtp->u.p.current_unit->s, length, SEEK_CUR) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); @@ -3540,6 +3757,18 @@ finalize_transfer (st_parameter_dt *dtp) { GFC_INTEGER_4 cf = dtp->common.flags; + if ((dtp->u.p.ionml != NULL) + && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) + { + if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) + namelist_read (dtp); + else + namelist_write (dtp); + } + + if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0)) + return; + if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) *dtp->size = dtp->u.p.size_used; @@ -3556,15 +3785,6 @@ finalize_transfer (st_parameter_dt *dtp) goto done; } - if ((dtp->u.p.ionml != NULL) - && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) - { - if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) - namelist_read (dtp); - else - namelist_write (dtp); - } - dtp->u.p.transfer = NULL; if (dtp->u.p.current_unit == NULL) goto done; @@ -3607,7 +3827,7 @@ finalize_transfer (st_parameter_dt *dtp) write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); tmp = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); - dtp->u.p.max_pos = + dtp->u.p.max_pos = dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; dtp->u.p.skips = 0; } @@ -3618,9 +3838,9 @@ finalize_transfer (st_parameter_dt *dtp) fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); goto done; } - else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED + 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); + fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); dtp->u.p.current_unit->saved_pos = 0; @@ -3648,9 +3868,9 @@ finalize_transfer (st_parameter_dt *dtp) data transfer, it just updates the length counter. */ static void -iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), +iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), void *dest __attribute__ ((unused)), - int kind __attribute__((unused)), + int kind __attribute__((unused)), size_t size, size_t nelems) { if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) @@ -3722,7 +3942,7 @@ void st_read_done (st_parameter_dt *dtp) { finalize_transfer (dtp); - + if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) { free_format_data (dtp->u.p.fmt); @@ -3735,7 +3955,7 @@ st_read_done (st_parameter_dt *dtp) unlock_unit (dtp->u.p.current_unit); free_internal_unit (dtp); - + library_end (); } @@ -3759,8 +3979,9 @@ st_write_done (st_parameter_dt *dtp) /* Deal with endfile conditions associated with sequential files. */ - if (dtp->u.p.current_unit != NULL - && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + if (dtp->u.p.current_unit != NULL + && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL + && dtp->u.p.current_unit->child_dtio == 0) switch (dtp->u.p.current_unit->endfile) { case AT_ENDFILE: /* Remain at the endfile record. */ @@ -3773,7 +3994,7 @@ st_write_done (st_parameter_dt *dtp) case NO_ENDFILE: /* Get rid of whatever is after this record. */ if (!is_internal_unit (dtp)) - unit_truncate (dtp->u.p.current_unit, + unit_truncate (dtp->u.p.current_unit, stell (dtp->u.p.current_unit->s), &dtp->common); dtp->u.p.current_unit->endfile = AT_ENDFILE; @@ -3790,7 +4011,7 @@ st_write_done (st_parameter_dt *dtp) if (dtp->u.p.current_unit != NULL) unlock_unit (dtp->u.p.current_unit); - + free_internal_unit (dtp); library_end (); @@ -3807,15 +4028,10 @@ st_wait (st_parameter_wait *wtp __attribute__((unused))) /* Receives the scalar information for namelist objects and stores it in a linked list of namelist_info types. */ -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 (st_parameter_dt *dtp, void * var_addr, char * var_name, - GFC_INTEGER_4 len, gfc_charlen_type string_length, - GFC_INTEGER_4 dtype) +static void +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, void *dtio_sub, void *vtable) { namelist_info *t1 = NULL; namelist_info *nml; @@ -3824,6 +4040,8 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, nml = (namelist_info*) xmalloc (sizeof (namelist_info)); nml->mem_pos = var_addr; + nml->dtio_sub = dtio_sub; + nml->vtable = vtable; nml->var_name = (char*) xmalloc (var_name_len + 1); memcpy (nml->var_name, var_name, var_name_len); @@ -3863,6 +4081,37 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name, } } +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 (st_parameter_dt *dtp, void * var_addr, char * var_name, + GFC_INTEGER_4 len, gfc_charlen_type string_length, + GFC_INTEGER_4 dtype) +{ + set_nml_var (dtp, var_addr, var_name, len, string_length, + dtype, NULL, NULL); +} + + +/* Essentially the same as previous but carrying the dtio procedure + and the vtable as additional arguments. */ +extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *, + GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4, + void *, void *); +export_proto(st_set_nml_dtio_var); + + +void +st_set_nml_dtio_var (st_parameter_dt *dtp, void * var_addr, char * var_name, + GFC_INTEGER_4 len, gfc_charlen_type string_length, + GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable) +{ + set_nml_var (dtp, var_addr, var_name, len, string_length, + dtype, dtio_sub, vtable); +} + /* Store the dimensional information for the namelist object. */ extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, index_type, index_type, @@ -3911,7 +4160,7 @@ hit_eof (st_parameter_dt * dtp) 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; diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index e0e7b09f..fde9ac7 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -348,7 +348,7 @@ retry: } found: - if (p != NULL) + if (p != NULL && (p->child_dtio == 0)) { /* Fast path. */ if (! __gthread_mutex_trylock (&p->lock)) @@ -363,7 +363,7 @@ found: __gthread_mutex_unlock (&unit_lock); - if (p != NULL) + if (p != NULL && (p->child_dtio == 0)) { __gthread_mutex_lock (&p->lock); if (p->closed) @@ -464,7 +464,7 @@ get_internal_unit (st_parameter_dt *dtp) else len = string_len_trim_char4 (dtp->internal_unit_len, (const gfc_char4_t*) dtp->internal_unit); - dtp->internal_unit_len = len; + dtp->internal_unit_len = len; iunit->recl = dtp->internal_unit_len; } @@ -524,7 +524,7 @@ get_internal_unit (st_parameter_dt *dtp) dtp->u.p.at_eof = 0; /* This flag tells us the unit is assigned to internal I/O. */ - + dtp->u.p.unit_is_internal = 1; return iunit; @@ -544,13 +544,13 @@ free_internal_unit (st_parameter_dt *dtp) if (dtp->u.p.current_unit != NULL) { free (dtp->u.p.current_unit->ls); - + free (dtp->u.p.current_unit->s); - + destroy_unit_mutex (dtp->u.p.current_unit); } } - + /* get_unit()-- Returns the unit structure associated with the integer @@ -612,14 +612,14 @@ init_units (void) u->flags.encoding = ENCODING_DEFAULT; u->flags.async = ASYNC_NO; u->flags.round = ROUND_UNSPECIFIED; - + u->recl = options.default_recl; u->endfile = NO_ENDFILE; u->filename = strdup (stdin_name); fbuf_init (u, 0); - + __gthread_mutex_unlock (&u->lock); } @@ -644,9 +644,9 @@ init_units (void) u->recl = options.default_recl; u->endfile = AT_ENDFILE; - + u->filename = strdup (stdout_name); - + fbuf_init (u, 0); __gthread_mutex_unlock (&u->lock); @@ -674,7 +674,7 @@ init_units (void) u->endfile = AT_ENDFILE; u->filename = strdup (stderr_name); - + fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing any kind of exotic formatting to stderr. */ @@ -694,7 +694,7 @@ static int close_unit_1 (gfc_unit *u, int locked) { int i, rc; - + /* If there are previously written bytes from a write with ADVANCE="no" Reposition the buffer before closing. */ if (u->previous_nonadvancing_write) @@ -715,7 +715,7 @@ close_unit_1 (gfc_unit *u, int locked) free (u->filename); u->filename = NULL; - free_format_hash_table (u); + free_format_hash_table (u); fbuf_destroy (u); if (!locked) @@ -788,7 +788,7 @@ unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common) else fbuf_flush (u, u->mode); } - + /* struncate() should flush the stream buffer if necessary, so don't bother calling sflush() here. */ ret = struncate (u->s, pos); @@ -838,7 +838,7 @@ filename_from_unit (int n) void finish_last_advance_record (gfc_unit *u) { - + if (u->saved_pos > 0) fbuf_seek (u, u->saved_pos, SEEK_CUR); diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index bdec1e8..29818cd 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -1121,7 +1121,7 @@ tempfile_open (const char *tempdir, char **fname) ) slash = ""; - // Take care that the template is longer in the mktemp() branch. + /* Take care that the template is longer in the mktemp() branch. */ char * template = xmalloc (tempdirlen + 23); #ifdef HAVE_MKSTEMP diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index db27f2d..15f7158 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -44,7 +44,7 @@ static void memcpy4 (gfc_char4_t *dest, const char *source, int k) { int j; - + const char *p = source; for (j = 0; j < k; j++) *dest++ = (gfc_char4_t) *p++; @@ -63,7 +63,7 @@ write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source, int j, k = 0; gfc_char4_t c; uchar d; - + /* Take care of preceding blanks. */ if (w_len > src_len) { @@ -153,7 +153,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source, static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE }; int nbytes; - uchar buf[6], d, *q; + uchar buf[6], d, *q; /* Take care of preceding blanks. */ if (w_len > src_len) @@ -273,7 +273,7 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) bytes = 0; } - /* Write out the CR_LF sequence. */ + /* Write out the CR_LF sequence. */ q++; p = write_block (dtp, 2); if (p == NULL) @@ -381,7 +381,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len bytes = 0; } - /* Write out the CR_LF sequence. */ + /* Write out the CR_LF sequence. */ write_default_char4 (dtp, crlf, 2, 0); } else @@ -528,7 +528,7 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) GFC_INTEGER_LARGEST n; wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w; - + p = write_block (dtp, wlen); if (p == NULL) return; @@ -694,7 +694,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, if (n < 0) n = -n; nsign = sign == S_NONE ? 0 : 1; - + /* conv calls itoa which sets the negative sign needed by write_integer. The sign '+' or '-' is set below based on sign calculated above, so we just point past the sign in the string @@ -847,7 +847,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) { char *q; int i, j; - + q = buffer; if (big_endian) { @@ -893,7 +893,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) if (*n == 0) return "0"; - /* Move past any leading zeros. */ + /* Move past any leading zeros. */ while (*buffer == '0') buffer++; @@ -968,7 +968,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) if (*n == 0) return "0"; - /* Move past any leading zeros. */ + /* Move past any leading zeros. */ while (*q == '0') q++; @@ -986,9 +986,9 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) char *q; uint8_t h, l; int i; - + q = buffer; - + if (big_endian) { const char *p = s; @@ -1021,11 +1021,11 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) } *q = '\0'; - + if (*n == 0) return "0"; - - /* Move past any leading zeros. */ + + /* Move past any leading zeros. */ while (*buffer == '0') buffer++; @@ -1067,7 +1067,7 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len) const char *p; char itoa_buf[GFC_OTOA_BUF_SIZE]; GFC_UINTEGER_LARGEST n = 0; - + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) { p = otoa_big (source, itoa_buf, len, &n); @@ -1407,12 +1407,12 @@ write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kin /* Precision for snprintf call. */ int precision = get_precision (dtp, f, source, kind); - + /* String buffer to hold final result. */ result = select_string (f, str_buf, &res_len); - + buffer = select_buffer (precision, buf_stack, &buf_size); - + get_float_string (dtp, f, source , kind, 0, buffer, precision, buf_size, result, &res_len); write_float_string (dtp, result, res_len); @@ -1525,13 +1525,13 @@ write_real (st_parameter_dt *dtp, const char *source, int kind) /* Precision for snprintf call. */ int precision = get_precision (dtp, &f, source, kind); - + /* String buffer to hold final result. */ result = select_string (&f, str_buf, &res_len); /* scratch buffer to hold final result. */ buffer = select_buffer (precision, buf_stack, &buf_size); - + get_float_string (dtp, &f, source , kind, 1, buffer, precision, buf_size, result, &res_len); write_float_string (dtp, result, res_len); @@ -1554,7 +1554,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d) char str_buf[BUF_STACK_SZ]; char *buffer, *result; size_t buf_size, res_len; - int comp_d; + int comp_d; set_fnode_default (dtp, &f, kind); if (d > 0) @@ -1570,7 +1570,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d) /* Precision for snprintf call. */ int precision = get_precision (dtp, &f, source, kind); - + /* String buffer to hold final result. */ result = select_string (&f, str_buf, &res_len); @@ -1608,36 +1608,36 @@ write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size) dtp->u.p.scale_factor = 1; set_fnode_default (dtp, &f, kind); - + /* Set width for two values, parenthesis, and comma. */ width = 2 * f.u.real.w + 3; /* Set for no blanks so we get a string result with no leading blanks. We will pad left later. */ dtp->u.p.g0_no_blanks = 1; - + /* Precision for snprintf call. */ int precision = get_precision (dtp, &f, source, kind); - + /* String buffers to hold final result. */ result1 = select_string (&f, str1_buf, &res_len1); result2 = select_string (&f, str2_buf, &res_len2); buffer = select_buffer (precision, buf_stack, &buf_size); - + get_float_string (dtp, &f, source , kind, 0, buffer, precision, buf_size, result1, &res_len1); get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer, precision, buf_size, result2, &res_len2); lblanks = width - res_len1 - res_len2 - 3; - + write_x (dtp, lblanks, lblanks); write_char (dtp, '('); write_float_string (dtp, result1, res_len1); write_char (dtp, semi_comma); write_float_string (dtp, result2, res_len2); write_char (dtp, ')'); - + dtp->u.p.scale_factor = orig_scale; dtp->u.p.g0_no_blanks = 0; if (buf_size > BUF_STACK_SZ) @@ -1710,6 +1710,46 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, case BT_COMPLEX: write_complex (dtp, p, kind, size); break; + case BT_CLASS: + { + int unit = dtp->u.p.current_unit->unit_number; + char iotype[] = "LISTDIRECTED"; + gfc_charlen_type iotype_len = 12; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + gfc_array_i4 vlist; + + GFC_DESCRIPTOR_DATA(&vlist) = NULL; + GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsge, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + + /* Call the user defined formatted WRITE procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + } + break; default: internal_error (&dtp->common, "list_formatted_write(): Bad type"); } @@ -1844,7 +1884,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, size_t base_name_len; size_t base_var_name_len; size_t tot_len; - + /* Set the character to be used to separate values to a comma or semi-colon. */ @@ -1903,7 +1943,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, break; default: - obj_size = len; + obj_size = len; } if (obj->var_rank) @@ -1985,7 +2025,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, break; case BT_DERIVED: - + case BT_CLASS: /* To treat a derived type, we need to build two strings: ext_name = the name, including qualifiers that prepends component names in the output - passed to @@ -1995,19 +2035,65 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, components. */ /* First ext_name => get length of all possible components */ + if (obj->dtio_sub != NULL) + { + int unit = dtp->u.p.current_unit->unit_number; + char iotype[] = "NAMELIST"; + gfc_charlen_type iotype_len = 8; + char tmp_iomsg[IOMSG_LEN] = ""; + char *child_iomsg; + gfc_charlen_type child_iomsg_len; + int noiostat; + int *child_iostat = NULL; + gfc_array_i4 vlist; + gfc_class list_obj; + formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub; + + GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + + list_obj.data = p; + list_obj.vptr = obj->vtable; + list_obj.len = 0; + + /* Set iostat, intent(out). */ + noiostat = 0; + child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? + dtp->common.iostat : &noiostat; + + /* Set iomsg, intent(inout). */ + if (dtp->common.flags & IOPARM_HAS_IOMSG) + { + child_iomsg = dtp->common.iomsg; + child_iomsg_len = dtp->common.iomsg_len; + } + else + { + child_iomsg = tmp_iomsg; + child_iomsg_len = IOMSG_LEN; + } + namelist_write_newline (dtp); + /* Call the user defined formatted WRITE procedure. */ + dtp->u.p.current_unit->child_dtio++; + dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, + child_iostat, child_iomsg, + iotype_len, child_iomsg_len); + dtp->u.p.current_unit->child_dtio--; + + goto obj_loop; + } base_name_len = base_name ? strlen (base_name) : 0; base_var_name_len = base ? strlen (base->var_name) : 0; - ext_name_len = base_name_len + base_var_name_len + ext_name_len = base_name_len + base_var_name_len + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1; ext_name = xmalloc (ext_name_len); if (base_name) memcpy (ext_name, base_name, base_name_len); clen = strlen (obj->var_name + base_var_name_len); - memcpy (ext_name + base_name_len, + memcpy (ext_name + base_name_len, obj->var_name + base_var_name_len, clen); - + /* Append the qualifier. */ tot_len = base_name_len + clen; @@ -2018,7 +2104,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, ext_name[tot_len] = '('; tot_len++; } - snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d", + snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d", (int) obj->ls[dim_i].idx); tot_len += strlen (ext_name + tot_len); ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ','; |