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