diff options
Diffstat (limited to 'libgfortran/io/write.c')
| -rw-r--r-- | libgfortran/io/write.c | 158 |
1 files changed, 122 insertions, 36 deletions
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) ? ')' : ','; |