Hi all,
The attached patch includes adjustments to the test case.
The Fortran Standard states the exponent width when using the e0
exponent specfier results in the smallest possible exponent width. This
patch implements that case.
I got frustrated with trying to re-understand this code segment and even
found some dead code in there. As a result I did some major refactoring
of the code and separated out the zero width, positive width, and no
width DEC extensions into their own chunks. I also added comments in
hopes of helping others follow what this is doing and how it works.
This patch resolves some parsing issues currently on trunk where a
format specifier following the e0.d.e specifier would result in an error
(comments 12 and 20 of the PR). These are fixed.
The patch, as it is, passes regression testing but I must confess I may
not have all the DEC stuff right yet and I propose we commit the patch
here and address any DEC stuff as a follow up. (I will be looking at the
DEC stuff in the next few days.)
OK for trunk?
Regards,
Jerry
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/io/format.c b/libgfortran/io/format.c
index 0b23721c055..1406e46693a 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,6 +925,8 @@ 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;
@@ -935,6 +937,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 +946,120 @@ 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)
+ *seen_dd = true;
+ 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)
- {
- notify_std (&dtp->common, GFC_STD_F2018,
- "Positive exponent width required");
- }
- else
+ u = format_lex (fmt);
+ if (u != FMT_POSINT)
{
- 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->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 5b89d47e613..33cd537c8a8 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 43b22bf5f8d..f63a77507fa 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 5ebe83b0dbd..0a5e5ed6f65 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 ce6aec83114..42ecf64ea68 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. */
