diff options
Diffstat (limited to 'libgfortran/io/write.c')
| -rw-r--r-- | libgfortran/io/write.c | 222 |
1 files changed, 185 insertions, 37 deletions
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 6135d60..ed50e0d 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -124,6 +124,108 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) #endif } + +/* The primary difference between write_a_char4 and write_a is that we have to + deal with writing from the first byte of the 4-byte character and take care + of endianess. This currently implements encoding="default" which means we + write the lowest significant byte. If the 3 most significant bytes are + not representable emit a '?'. TODO: Implement encoding="UTF-8" + which will process all 4 bytes and translate to the encoded output. */ + +void +write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len) +{ + int wlen; + char *p; + gfc_char4_t *q; + + wlen = f->u.string.length < 0 + || (f->format == FMT_G && f->u.string.length == 0) + ? len : f->u.string.length; + + q = (gfc_char4_t *) source; +#ifdef HAVE_CRLF + /* If this is formatted STREAM IO convert any embedded line feed characters + to CR_LF on systems that use that sequence for newlines. See F2003 + Standard sections 10.6.3 and 9.9 for further information. */ + if (is_stream_io (dtp)) + { + const char crlf[] = "\r\n"; + int i, j, bytes; + gfc_char4_t *qq; + bytes = 0; + + /* Write out any padding if needed. */ + if (len < wlen) + { + p = write_block (dtp, wlen - len); + if (p == NULL) + return; + memset (p, ' ', wlen - len); + } + + /* Scan the source string looking for '\n' and convert it if found. */ + qq = (gfc_char4_t *) source; + for (i = 0; i < wlen; i++) + { + if (qq[i] == '\n') + { + /* Write out the previously scanned characters in the string. */ + if (bytes > 0) + { + p = write_block (dtp, bytes); + if (p == NULL) + return; + for (j = 0; j < bytes; j++) + p[j] = q[j] > 255 ? '?' : (unsigned char) q[j]; + bytes = 0; + } + + /* Write out the CR_LF sequence. */ + p = write_block (dtp, 2); + if (p == NULL) + return; + memcpy (p, crlf, 2); + } + else + bytes++; + } + + /* Write out any remaining bytes if no LF was found. */ + if (bytes > 0) + { + p = write_block (dtp, bytes); + if (p == NULL) + return; + for (j = 0; j < bytes; j++) + p[j] = q[j] > 255 ? '?' : (unsigned char) q[j]; + } + } + else + { +#endif + int j; + p = write_block (dtp, wlen); + if (p == NULL) + return; + + if (wlen < len) + { + for (j = 0; j < wlen; j++) + p[j] = q[j] > 255 ? '?' : (unsigned char) q[j]; + } + else + { + memset (p, ' ', wlen - len); + for (j = wlen - len; j < wlen; j++) + p[j] = q[j] > 255 ? '?' : (unsigned char) q[j]; + } +#ifdef HAVE_CRLF + } +#endif +} + + static GFC_INTEGER_LARGEST extract_int (const void *p, int len) { @@ -639,10 +741,12 @@ write_integer (st_parameter_dt *dtp, const char *source, int length) the strings if the file has been opened in that mode. */ static void -write_character (st_parameter_dt *dtp, const char *source, int length) +write_character (st_parameter_dt *dtp, const char *source, int kind, int length) { int i, extra; char *p, d; + gfc_char4_t *q; + switch (dtp->u.p.delim_status) { @@ -657,35 +761,77 @@ write_character (st_parameter_dt *dtp, const char *source, int length) break; } - if (d == ' ') - extra = 0; - else + if (kind == 1) { - extra = 2; + if (d == ' ') + extra = 0; + else + { + extra = 2; - for (i = 0; i < length; i++) - if (source[i] == d) - extra++; - } + for (i = 0; i < length; i++) + if (source[i] == d) + extra++; + } - p = write_block (dtp, length + extra); - if (p == NULL) - return; + p = write_block (dtp, length + extra); + if (p == NULL) + return; + + if (d == ' ') + memcpy (p, source, length); + else + { + *p++ = d; - if (d == ' ') - memcpy (p, source, length); + for (i = 0; i < length; i++) + { + *p++ = source[i]; + if (source[i] == d) + *p++ = d; + } + + *p = d; + } + } else { - *p++ = d; - - for (i = 0; i < length; i++) + /* We have to scan the source string looking for delimiters to determine + how large the write block needs to be. */ + if (d == ' ') + extra = 0; + else { - *p++ = source[i]; - if (source[i] == d) - *p++ = d; + extra = 2; + + q = (gfc_char4_t *) source; + for (i = 0; i < length; i++, q++) + if (*q == (gfc_char4_t) d) + extra++; } - *p = d; + p = write_block (dtp, length + extra); + if (p == NULL) + return; + + if (d == ' ') + { + q = (gfc_char4_t *) source; + for (i = 0; i < length; i++, q++) + p[i] = *q > 255 ? '?' : (unsigned char) *q; + } + else + { + *p++ = d; + q = (gfc_char4_t *) source; + for (i = 0; i < length; i++, q++) + { + *p++ = *q > 255 ? '?' : (unsigned char) *q; + if (*q == (gfc_char4_t) d) + *p++ = d; + } + *p = d; + } } } @@ -796,7 +942,7 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, write_logical (dtp, p, kind); break; case BT_CHARACTER: - write_character (dtp, p, kind); + write_character (dtp, p, kind, size); break; case BT_REAL: write_real (dtp, p, kind); @@ -818,6 +964,8 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind, { size_t elem; char *tmp; + size_t stride = type == BT_CHARACTER ? + size * GFC_SIZE_OF_CHAR_KIND(kind) : size; tmp = (char *) p; @@ -825,7 +973,7 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind, for (elem = 0; elem < nelems; elem++) { dtp->u.p.item_count++; - list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size); + list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size); } } @@ -889,9 +1037,9 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, if (obj->type != GFC_DTYPE_DERIVED) { #ifdef HAVE_CRLF - write_character (dtp, "\r\n ", 3); + write_character (dtp, "\r\n ", 1, 3); #else - write_character (dtp, "\n ", 2); + write_character (dtp, "\n ", 1, 2); #endif len = 0; if (base) @@ -900,15 +1048,15 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++) { cup = toupper (base_name[dim_i]); - write_character (dtp, &cup, 1); + write_character (dtp, &cup, 1, 1); } } for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++) { cup = toupper (obj->var_name[dim_i]); - write_character (dtp, &cup, 1); + write_character (dtp, &cup, 1, 1); } - write_character (dtp, "=", 1); + write_character (dtp, "=", 1, 1); } /* Counts the number of data output on a line, including names. */ @@ -978,7 +1126,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, if (rep_ctr > 1) { sprintf(rep_buff, " %d*", rep_ctr); - write_character (dtp, rep_buff, strlen (rep_buff)); + write_character (dtp, rep_buff, 1, strlen (rep_buff)); dtp->u.p.no_leading_blank = 1; } num++; @@ -1003,7 +1151,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, dtp->u.p.delim_status = DELIM_QUOTE; if (dtp->u.p.nml_delim == '\'') dtp->u.p.delim_status = DELIM_APOSTROPHE; - write_character (dtp, p, obj->string_length); + write_character (dtp, p, 1, obj->string_length); dtp->u.p.delim_status = tmp_delim; break; @@ -1093,14 +1241,14 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset, to column 2. Reset the repeat counter. */ dtp->u.p.no_leading_blank = 0; - write_character (dtp, &semi_comma, 1); + write_character (dtp, &semi_comma, 1, 1); if (num > 5) { num = 0; #ifdef HAVE_CRLF - write_character (dtp, "\r\n ", 3); + write_character (dtp, "\r\n ", 1, 3); #else - write_character (dtp, "\n ", 2); + write_character (dtp, "\n ", 1, 2); #endif } rep_ctr = 1; @@ -1164,13 +1312,13 @@ namelist_write (st_parameter_dt *dtp) /* Temporarily disable namelist delimters. */ dtp->u.p.delim_status = DELIM_NONE; - write_character (dtp, "&", 1); + write_character (dtp, "&", 1, 1); /* Write namelist name in upper case - f95 std. */ for (i = 0 ;i < dtp->namelist_name_len ;i++ ) { c = toupper (dtp->namelist_name[i]); - write_character (dtp, &c ,1); + write_character (dtp, &c, 1 ,1); } if (dtp->u.p.ionml != NULL) @@ -1184,9 +1332,9 @@ namelist_write (st_parameter_dt *dtp) } #ifdef HAVE_CRLF - write_character (dtp, " /\r\n", 5); + write_character (dtp, " /\r\n", 1, 5); #else - write_character (dtp, " /\n", 4); + write_character (dtp, " /\n", 1, 4); #endif /* Restore the original delimiter. */ |