diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 12f934d6571e8adb71ae348fc4328ebc03e991ab..1ccff579b4ed936728bbef7736ae7d680a39f5ed 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2020-01-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR libfortran/90374
+ * gfortran.dg/fmt_zero_width.f90: Update test case.
+
2020-01-01 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/93113
diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
index 640b6735c65a72774528cc1924a3a23854356a29..db2cca6e28abcd7c8b16143cfdc1a51831171a54 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 35cd60e7686d63585d963c98c4640a4ac403a279..840642cd660fdffc2523281c4e863a96e3dbda6a 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,20 @@
+2020-01-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <jakub@redhat.com>
Update copyright years.
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 70e88aaab49d75c5c04bbf82c10d17761478070b..b42a5593e38a1ae548b5fc785c97da5b14810cd7 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");
+ if (u != FMT_ZERO && u != FMT_POSINT)
+ {
+ fmt->error = nonneg_required;
+ goto finished;
+ }
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)
+
+ /* Look for optional exponent */
+ u = format_lex (fmt);
+ if (u != FMT_E)
+ fmt->saved_token = u;
+ else
{
- if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+ u = format_lex (fmt);
+ if (u != FMT_POSINT)
{
- tail->u.real.w = DEFAULT_WIDTH;
- tail->u.real.d = 0;
- tail->u.real.e = -1;
- fmt->saved_token = u;
- break;
+ 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;
+ }
}
- fmt->error = nonneg_required;
- goto finished;
+ tail->u.real.e = fmt->value;
}
+ break;
}
- else if (u == FMT_ZERO)
- {
- fmt->error = posint_required;
- goto finished;
- }
- else if (u != FMT_POSINT)
+
+ /* Processing for positive width formats. */
+ if (u == FMT_POSINT)
{
- if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+ 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)
{
- tail->u.real.w = DEFAULT_WIDTH;
+ /* 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;
- 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)
+ /* 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 = period_required;
+ fmt->error = nonneg_required;
goto finished;
}
- fmt->saved_token = t;
- tail->u.real.d = 0;
+ tail->u.real.d = fmt->value;
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;
- }
+ /* Done with D and F formats. */
+ 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)
+ /* Look for optional exponent */
+ u = format_lex (fmt);
+ if (u != FMT_E)
+ fmt->saved_token = u;
+ else
{
- if (t == FMT_ZERO)
+ u = format_lex (fmt);
+ if (u != FMT_POSINT)
{
- 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;
+ 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;
}
- 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 7296cbe4a83b8baf31d585d9246e4cef4a15ffd2..ab4a103787c1534be26395f366b29b4a10c473ea 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 5e07a5b4957e19c193d5fbdbf530105a2af6b31b..b8db47dbff9dbe03fbd990424a0134c98521c2c0 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 1387d5fb70391fe0207bff648a3b2d29e05582fa..9f02683a25c61388834f0872b54b6731ce168056 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 912ad645887ffc3fce4d29ce28a3a6291b11446b..75c7942c4c5cb9199d148695e587901836806072 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. */