diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 12f934d6571..1ccff579b4e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2020-01-01 Jerry DeLisle + + PR libfortran/90374 + * gfortran.dg/fmt_zero_width.f90: Update test case. + 2020-01-01 Thomas Koenig PR fortran/93113 diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 index 640b6735c65..db2cca6e28a 100644 --- a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 @@ -9,32 +9,34 @@ program pr90374 rn = 0.00314_4 afmt = "(D0.3)" write (aresult,fmt=afmt) rn - if (aresult /= "0.314D-02") stop 12 + if (aresult /= "0.314D-2") stop 12 afmt = "(E0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "0.3139999928E-02") stop 15 + if (aresult /= "0.3139999928E-2") stop 15 afmt = "(ES0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "3.1399999280E-03") stop 18 + if (aresult /= "3.1399999280E-3") stop 18 afmt = "(EN0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "3.1399999280E-03") stop 21 + if (aresult /= "3.1399999280E-3") stop 21 afmt = "(G0.10)" write (aresult,fmt=afmt) rn - if (aresult /= "0.3139999928E-02") stop 24 + if (aresult /= "0.3139999928E-2") stop 24 afmt = "(E0.10e0)" write (aresult,fmt=afmt) rn - if (aresult /= "0.3139999928E-02") stop 27 + if (aresult /= "0.3139999928E-2") stop 27 write (aresult,fmt="(D0.3)") rn - if (aresult /= "0.314D-02") stop 29 + if (aresult /= "0.314D-2") stop 29 write (aresult,fmt="(E0.10)") rn - if (aresult /= "0.3139999928E-02") stop 31 + if (aresult /= "0.3139999928E-2") stop 31 write (aresult,fmt="(ES0.10)") rn - if (aresult /= "3.1399999280E-03") stop 33 + if (aresult /= "3.1399999280E-3") stop 33 write (aresult,fmt="(EN0.10)") rn - if (aresult /= "3.1399999280E-03") stop 35 + if (aresult /= "3.1399999280E-3") stop 35 write (aresult,fmt="(G0.10)") rn - if (aresult /= "0.3139999928E-02") stop 37 + if (aresult /= "0.3139999928E-2") stop 37 write (aresult,fmt="(E0.10e0)") rn - if (aresult /= "0.3139999928E-02") stop 39 + if (aresult /= "0.3139999928E-2") stop 39 + write (aresult,fmt="(E0.10e3)") rn + if (aresult /= ".3139999928E-002") stop 41 end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 35cd60e7686..840642cd660 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,20 @@ +2020-01-01 Jerry DeLisle + + PR libfortran/90374 + * io/format.c (parse_format_list): Implement the E0 exponent + width to provide smallest possible width for exponent fields. + Refactor code for correct parsing and better readability of the + code. + * io/io.h (write_real_w0): Change interface to pass in pointer + to fnode. + * io/transfer.c: Update all calls to write_real_w0 to use the + new interface. + * io/write.c ((write_real_w0): Use the new interface with fnode + to access both the decimal precision and exponent widths used in + build_float_string. + * io/write_float.def (build_float_string): Use the passed in + exponent width to calculate the used width in the case of E0. + 2020-01-01 Jakub Jelinek Update copyright years. diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 70e88aaab49..b42a5593e38 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -38,7 +38,7 @@ static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0, /* Error messages. */ -static const char posint_required[] = "Positive width required in format", +static const char posint_required[] = "Positive integer required in format", period_required[] = "Period required in format", nonneg_required[] = "Nonnegative width required in format", unexpected_element[] = "Unexpected element '%c' in format\n", @@ -925,9 +925,10 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) tail->repeat = repeat; u = format_lex (fmt); + + /* Processing for zero width formats. */ if (u == FMT_ZERO) { - *seen_dd = true; if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR || dtp->u.p.mode == READING) { @@ -935,6 +936,8 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) goto finished; } tail->u.real.w = 0; + + /* Look for the dot seperator. */ u = format_lex (fmt); if (u != FMT_PERIOD) { @@ -942,108 +945,119 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) break; } + /* Look for the precision. */ u = format_lex (fmt); - if (u != FMT_POSINT) - notify_std (&dtp->common, GFC_STD_F2003, - "Positive width required"); - tail->u.real.d = fmt->value; - break; - } - if (t == FMT_F && dtp->u.p.mode == WRITING) - { - *seen_dd = true; - if (u != FMT_POSINT && u != FMT_ZERO) + if (u != FMT_ZERO && u != FMT_POSINT) { - if (dtp->common.flags & IOPARM_DT_DEC_EXT) - { - tail->u.real.w = DEFAULT_WIDTH; - tail->u.real.d = 0; - tail->u.real.e = -1; - fmt->saved_token = u; - break; - } fmt->error = nonneg_required; goto finished; } - } - else if (u == FMT_ZERO) - { - fmt->error = posint_required; - goto finished; - } - else if (u != FMT_POSINT) - { - if (dtp->common.flags & IOPARM_DT_DEC_EXT) + tail->u.real.d = fmt->value; + + /* Look for optional exponent */ + u = format_lex (fmt); + if (u != FMT_E) + fmt->saved_token = u; + else { - tail->u.real.w = DEFAULT_WIDTH; - tail->u.real.d = 0; - tail->u.real.e = -1; - fmt->saved_token = u; - break; - } - fmt->error = posint_required; - goto finished; - } - - tail->u.real.w = fmt->value; - t2 = t; - t = format_lex (fmt); - if (t != FMT_PERIOD) - { - /* We treat a missing decimal descriptor as 0. Note: This is only - allowed if -std=legacy, otherwise an error occurs. */ - if (compile_options.warn_std != 0) - { - fmt->error = period_required; - goto finished; - } - fmt->saved_token = t; - tail->u.real.d = 0; - tail->u.real.e = -1; - break; - } - - t = format_lex (fmt); - if (t != FMT_ZERO && t != FMT_POSINT) - { - fmt->error = nonneg_required; - goto finished; - } - - tail->u.real.d = fmt->value; - tail->u.real.e = -1; - - if (t2 == FMT_D || t2 == FMT_F) - { - *seen_dd = true; - break; - } - - /* Look for optional exponent */ - t = format_lex (fmt); - if (t != FMT_E) - fmt->saved_token = t; - else - { - t = format_lex (fmt); - if (t != FMT_POSINT) - { - if (t == FMT_ZERO) + u = format_lex (fmt); + if (u != FMT_POSINT) { - notify_std (&dtp->common, GFC_STD_F2018, - "Positive exponent width required"); + if (u == FMT_ZERO) + { + notify_std (&dtp->common, GFC_STD_F2018, + "Positive exponent width required"); + } + else + { + fmt->error = "Positive exponent width required in " + "format string at %L"; + goto finished; + } } - else + tail->u.real.e = fmt->value; + } + break; + } + + /* Processing for positive width formats. */ + if (u == FMT_POSINT) + { + tail->u.real.w = fmt->value; + + /* Look for the dot separator. Because of legacy behaviors + we do some look ahead for missing things. */ + t2 = t; + t = format_lex (fmt); + if (t != FMT_PERIOD) + { + /* We treat a missing decimal descriptor as 0. Note: This is only + allowed if -std=legacy, otherwise an error occurs. */ + if (compile_options.warn_std != 0) { - fmt->error = "Positive exponent width required in " - "format string at %L"; + fmt->error = period_required; goto finished; } + fmt->saved_token = t; + tail->u.real.d = 0; + tail->u.real.e = -1; + break; } - tail->u.real.e = fmt->value; + + /* If we made it here, we should have the dot so look for the + precision. */ + t = format_lex (fmt); + if (t != FMT_ZERO && t != FMT_POSINT) + { + fmt->error = nonneg_required; + goto finished; + } + tail->u.real.d = fmt->value; + tail->u.real.e = -1; + + /* Done with D and F formats. */ + if (t2 == FMT_D || t2 == FMT_F) + { + *seen_dd = true; + break; + } + + /* Look for optional exponent */ + u = format_lex (fmt); + if (u != FMT_E) + fmt->saved_token = u; + else + { + u = format_lex (fmt); + if (u != FMT_POSINT) + { + if (u == FMT_ZERO) + { + notify_std (&dtp->common, GFC_STD_F2018, + "Positive exponent width required"); + } + else + { + fmt->error = "Positive exponent width required in " + "format string at %L"; + goto finished; + } + } + tail->u.real.e = fmt->value; + } + break; } + /* Old DEC codes may not have width or precision specified. */ + if (dtp->u.p.mode == WRITING && (dtp->common.flags & IOPARM_DT_DEC_EXT)) + { + tail->u.real.w = DEFAULT_WIDTH; + tail->u.real.d = 0; + tail->u.real.e = -1; + fmt->saved_token = u; + } break; + case FMT_DT: *seen_dd = true; get_fnode (fmt, &head, &tail, t); diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 7296cbe4a83..ab4a103787c 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -942,7 +942,7 @@ internal_proto(write_o); extern void write_real (st_parameter_dt *, const char *, int); internal_proto(write_real); -extern void write_real_w0 (st_parameter_dt *, const char *, int, format_token, int); +extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*); internal_proto(write_real_w0); extern void write_x (st_parameter_dt *, int, int); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 5e07a5b4957..b8db47dbff9 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2009,7 +2009,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin if (require_type (dtp, BT_REAL, type, f)) return; if (f->u.real.w == 0) - write_real_w0 (dtp, p, kind, FMT_D, f->u.real.d); + write_real_w0 (dtp, p, kind, f); else write_d (dtp, f, p, kind); break; @@ -2075,7 +2075,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin if (require_type (dtp, BT_REAL, type, f)) return; if (f->u.real.w == 0) - write_real_w0 (dtp, p, kind, FMT_E, f->u.real.d); + write_real_w0 (dtp, p, kind, f); else write_e (dtp, f, p, kind); break; @@ -2086,7 +2086,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin if (require_type (dtp, BT_REAL, type, f)) return; if (f->u.real.w == 0) - write_real_w0 (dtp, p, kind, FMT_EN, f->u.real.d); + write_real_w0 (dtp, p, kind, f); else write_en (dtp, f, p, kind); break; @@ -2097,7 +2097,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin if (require_type (dtp, BT_REAL, type, f)) return; if (f->u.real.w == 0) - write_real_w0 (dtp, p, kind, FMT_ES, f->u.real.d); + write_real_w0 (dtp, p, kind, f); else write_es (dtp, f, p, kind); break; @@ -2129,7 +2129,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin break; case BT_REAL: if (f->u.real.w == 0) - write_real_w0 (dtp, p, kind, FMT_G, f->u.real.d); + write_real_w0 (dtp, p, kind, f); else write_d (dtp, f, p, kind); break; diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 1387d5fb703..9f02683a25c 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1721,42 +1721,46 @@ write_real (st_parameter_dt *dtp, const char *source, int kind) void write_real_w0 (st_parameter_dt *dtp, const char *source, int kind, - format_token fmt, int d) + const fnode* f) { - fnode f; + fnode ff; char buf_stack[BUF_STACK_SZ]; char str_buf[BUF_STACK_SZ]; char *buffer, *result; size_t buf_size, res_len, flt_str_len; int comp_d = 0; - set_fnode_default (dtp, &f, kind); - if (d > 0) - f.u.real.d = d; - f.format = fmt; + set_fnode_default (dtp, &ff, kind); + + if (f->u.real.d > 0) + ff.u.real.d = f->u.real.d; + ff.format = f->format; /* For FMT_G, Compensate for extra digits when using scale factor, d is not specified, and the magnitude is such that E editing is used. */ - if (fmt == FMT_G) + if (f->format == FMT_G) { - if (dtp->u.p.scale_factor > 0 && d == 0) + if (dtp->u.p.scale_factor > 0 && f->u.real.d == 0) comp_d = 1; else comp_d = 0; } + if (f->u.real.e >= 0) + ff.u.real.e = f->u.real.e; + dtp->u.p.g0_no_blanks = 1; /* Precision for snprintf call. */ - int precision = get_precision (dtp, &f, source, kind); + int precision = get_precision (dtp, &ff, source, kind); /* String buffer to hold final result. */ - result = select_string (dtp, &f, str_buf, &res_len, kind); + result = select_string (dtp, &ff, str_buf, &res_len, kind); - buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind); + buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind); - get_float_string (dtp, &f, source , kind, comp_d, buffer, + get_float_string (dtp, &ff, source , kind, comp_d, buffer, precision, buf_size, result, &flt_str_len); write_float_string (dtp, result, flt_str_len); diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def index 912ad645887..75c7942c4c5 100644 --- a/libgfortran/io/write_float.def +++ b/libgfortran/io/write_float.def @@ -266,7 +266,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, case FMT_E: case FMT_D: i = dtp->u.p.scale_factor; - if (d <= 0 && p == 0) + if (d < 0 && p == 0) { generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not " "greater than zero in format specifier 'E' or 'D'"); @@ -482,7 +482,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, for (i = abs (e); i >= 10; i /= 10) edigits++; - if (f->u.real.e <= 0) + if (f->u.real.e < 0) { /* Width not specified. Must be no more than 3 digits. */ if (e > 999 || e < -999) @@ -494,6 +494,16 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, expchar = ' '; } } + else if (f->u.real.e == 0) + { + /* Zero width specified, no leading zeros in exponent */ + if (e > 99 || e < -99) + edigits = 5; + else if (e > 9 || e < -9) + edigits = 4; + else + edigits = 3; + } else { /* Exponent width specified, check it is wide enough. */