diff options
Diffstat (limited to 'libgfortran/io/write.c')
| -rw-r--r-- | libgfortran/io/write.c | 252 |
1 files changed, 227 insertions, 25 deletions
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index ee2ce0c3915..775425d6d77 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -36,10 +36,32 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include <errno.h> #define star_fill(p, n) memset(p, '*', n) -#include "write_float.def" - typedef unsigned char uchar; +/* Helper functions for character(kind=4) internal units. These are needed + by write_float.def. */ + +static inline void +memset4 (gfc_char4_t *p, gfc_char4_t c, int k) +{ + int j; + for (j = 0; j < k; j++) + *p++ = c; +} + +static inline 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++; +} + +/* This include contains the heart and soul of formatted floating point. */ +#include "write_float.def" + /* Write out default char4. */ static void @@ -58,7 +80,13 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source, p = write_block (dtp, k); if (p == NULL) return; - memset (p, ' ', k); + if (is_char4_unit (dtp)) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (p4, ' ', k); + } + else + memset (p, ' ', k); } /* Get ready to handle delimiters if needed. */ @@ -76,25 +104,48 @@ write_default_char4 (st_parameter_dt *dtp, gfc_char4_t *source, } /* Now process the remaining characters, one at a time. */ - for (j = k; j < src_len; j++) + for (j = 0; j < src_len; j++) { c = source[j]; - - /* Handle delimiters if any. */ - if (c == d && d != ' ') + if (is_char4_unit (dtp)) { - p = write_block (dtp, 2); - if (p == NULL) - return; - *p++ = (uchar) c; + gfc_char4_t *q; + /* Handle delimiters if any. */ + if (c == d && d != ' ') + { + p = write_block (dtp, 2); + if (p == NULL) + return; + q = (gfc_char4_t *) p; + *q++ = c; + } + else + { + p = write_block (dtp, 1); + if (p == NULL) + return; + q = (gfc_char4_t *) p; + } + *q = c; } else { - p = write_block (dtp, 1); - if (p == NULL) - return; + /* Handle delimiters if any. */ + if (c == d && d != ' ') + { + p = write_block (dtp, 2); + if (p == NULL) + return; + *p++ = (uchar) c; + } + else + { + p = write_block (dtp, 1); + if (p == NULL) + return; + } + *p = c > 255 ? '?' : (uchar) c; } - *p = c > 255 ? '?' : (uchar) c; } } @@ -258,6 +309,19 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len) if (p == NULL) return; + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + if (wlen < len) + memcpy4 (p4, source, wlen); + else + { + memset4 (p4, ' ', wlen - len); + memcpy4 (p4 + wlen - len, source, len); + } + return; + } + if (wlen < len) memcpy (p, source, wlen); else @@ -478,8 +542,17 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) if (p == NULL) return; - memset (p, ' ', wlen - 1); n = extract_int (source, len); + + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (p4, ' ', wlen -1); + p4[wlen - 1] = (n) ? 'T' : 'F'; + return; + } + + memset (p, ' ', wlen -1); p[wlen - 1] = (n) ? 'T' : 'F'; } @@ -503,8 +576,13 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) p = write_block (dtp, w); if (p == NULL) return; - - memset (p, ' ', w); + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (p4, ' ', w); + } + else + memset (p, ' ', w); goto done; } @@ -528,6 +606,35 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) nblank = w - (nzero + digits); + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + if (nblank < 0) + { + memset4 (p4, '*', w); + return; + } + + if (!dtp->u.p.no_leading_blank) + { + memset4 (p4, ' ', nblank); + q += nblank; + memset4 (p4, '0', nzero); + q += nzero; + memcpy4 (p4, q, digits); + } + else + { + memset4 (p4, '0', nzero); + q += nzero; + memcpy4 (p4, q, digits); + q += digits; + memset4 (p4, ' ', nblank); + dtp->u.p.no_leading_blank = 0; + } + return; + } + if (nblank < 0) { star_fill (p, w); @@ -582,8 +689,13 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, p = write_block (dtp, w); if (p == NULL) return; - - memset (p, ' ', w); + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (p4, ' ', w); + } + else + memset (p, ' ', w); goto done; } @@ -621,6 +733,37 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, nblank = w - (nsign + nzero + digits); + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t * p4 = (gfc_char4_t *) p; + if (nblank < 0) + { + memset4 (p4, '*', w); + goto done; + } + + memset4 (p4, ' ', nblank); + p4 += nblank; + + switch (sign) + { + case S_PLUS: + *p4++ = '+'; + break; + case S_MINUS: + *p4++ = '-'; + break; + case S_NONE: + break; + } + + memset4 (p4, '0', nzero); + p4 += nzero; + + memcpy4 (p4, q, digits); + return; + } + if (nblank < 0) { star_fill (p, w); @@ -1055,7 +1198,15 @@ write_x (st_parameter_dt *dtp, int len, int nspaces) if (p == NULL) return; if (nspaces > 0 && len - nspaces >= 0) - memset (&p[len - nspaces], ' ', nspaces); + { + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memset4 (&p4[len - nspaces], ' ', nspaces); + } + else + memset (&p[len - nspaces], ' ', nspaces); + } } @@ -1066,15 +1217,21 @@ write_x (st_parameter_dt *dtp, int len, int nspaces) something goes wrong. */ static int -write_char (st_parameter_dt *dtp, char c) +write_char (st_parameter_dt *dtp, int c) { char *p; p = write_block (dtp, 1); if (p == NULL) return 1; + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + *p4 = c; + return 0; + } - *p = c; + *p = (uchar) c; return 0; } @@ -1132,6 +1289,23 @@ write_integer (st_parameter_dt *dtp, const char *source, int length) p = write_block (dtp, width); if (p == NULL) return; + + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + if (dtp->u.p.no_leading_blank) + { + memcpy4 (p4, q, digits); + memset4 (p4 + digits, ' ', width - digits); + } + else + { + memset4 (p4, ' ', width - digits); + memcpy4 (p4 + width - digits, q, digits); + } + return; + } + if (dtp->u.p.no_leading_blank) { memcpy (p, q, digits); @@ -1184,6 +1358,29 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length) if (p == NULL) return; + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t d4 = (gfc_char4_t) d; + gfc_char4_t *p4 = (gfc_char4_t *) p; + + if (d4 == ' ') + memcpy4 (p4, source, length); + else + { + *p4++ = d4; + + for (i = 0; i < length; i++) + { + *p4++ = (gfc_char4_t) source[i]; + if (source[i] == d) + *p4++ = d4; + } + + *p4 = d4; + } + return; + } + if (d == ' ') memcpy (p, source, length); else @@ -1316,8 +1513,13 @@ write_separator (st_parameter_dt *dtp) p = write_block (dtp, options.separator_len); if (p == NULL) return; - - memcpy (p, options.separator, options.separator_len); + if (unlikely (is_char4_unit (dtp))) + { + gfc_char4_t *p4 = (gfc_char4_t *) p; + memcpy4 (p4, options.separator, options.separator_len); + } + else + memcpy (p, options.separator, options.separator_len); } |