OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

PR 90374 d0.d, e0.d, es0.d, en0.d, g0.d and ew.d edit descriptors. 

PR libfortran/90274
        * 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.

From-SVN: r279828
This commit is contained in:
Jerry DeLisle 2020-01-02 00:57:31 +00:00
parent a7ff7c7250
commit 2b70275ee1
8 changed files with 173 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/testsuite/ChangeLog
View File

@ -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

26
gcc/testsuite/gfortran.dg/fmt_zero_width.f90
View File

@ -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

17
libgfortran/ChangeLog
View File

@ -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.

192
libgfortran/io/format.c
View File

@ -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);

2
libgfortran/io/io.h
View File

@ -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);

10
libgfortran/io/transfer.c
View File

@ -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;

28
libgfortran/io/write.c
View File

@ -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);

14
libgfortran/io/write_float.def
View File

@ -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. */