Skip to content

R
riscv-gcc-1
Commit 900e887f by Jerry DeLisle Committed by Daniel Kraft
Options

re PR fortran/37228 (F2008: Support g0.<d> edit descriptor) 

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/37228
	* io.c (check_format): Allow specifying precision with g0 format.

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/37301
	PR libfortran/37228
	* io/io.h (write_real_g0): Declare new function to handle g0.d format.
	* io/transfer.c (formatted_transfer_scalar): Use new function.
	* io/format.c (parse_format_list): Enable g0.d.
	* io/write.c (write_a_char4): Delete unused var.
	(set_fnode_default): New function to set the default fnode w, d, and e
	factored from write_real. (write_real): Use new factored function.
	(write_real_g0): New function that sets d to that passed by g0.d format
	specifier and set format to ES.  Default values for w and e are used
	from the new function, set_fnode_default.

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/37228
	* gfortran.dg/fmt_g0_4.f08: Revised test.

From-SVN: r139886
parent 52f49934
Showing with 112 additions and 38 deletions
gcc/fortran/ChangeLog
2008-09-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/37228
* io.c (check_format): Allow specifying precision with g0 format.
2008-09-02 Daniel Kraft <d@domob.eu>
* gfortran.h (struct gfc_namespace): New member `implicit_loc'.
......
gcc/fortran/io.c
......@@ -483,7 +483,6 @@ check_format (bool is_input)
" at %L");
const char *unexpected_end = _("Unexpected end of format string");
const char *zero_width = _("Zero width in format descriptor");
const char *g0_precision = _("Specifying precision with G0 not allowed");
const char *error;
format_token t, u;
......@@ -701,27 +700,25 @@ data_desc:
error = zero_width;
goto syntax;
}
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
"format at %C") == FAILURE)
return FAILURE;
u = format_lex ();
if (u != FMT_PERIOD)
{
saved_token = u;
break;
}
u = format_lex ();
if (u == FMT_PERIOD)
if (u == FMT_ERROR)
goto fail;
if (u != FMT_POSINT)
{
error = g0_precision;
error = posint_required;
goto syntax;
}
saved_token = u;
goto between_desc;
}
if (u == FMT_ERROR)
goto fail;
if (u != FMT_POSINT)
{
error = posint_required;
goto syntax;
break;
}
u = format_lex ();
......
gcc/testsuite/ChangeLog
2008-09-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/37228
* gfortran.dg/fmt_g0_4.f08: Revised test.
2008-09-02 Daniel Kraft <d@domob.eu>
* gfortran.dg/abstract_type_1.f90: New test.
......
gcc/testsuite/gfortran.dg/fmt_g0_4.f08
! { dg-do compile }
! { dg-options "-std=f2008" }
! PR36725 Compile time error for g0 edit descriptor
print '(g0.9)', 0.1 ! { dg-error "Specifying precision" }
character(30) :: line
write(line, '(g0.3)') 0.1
if (line.ne." 1.000E-01") call abort
write(line, '(g0.9)') 1.0
if (line.ne."1.000000000E+00") call abort
write(line, '(g0.5)') 29.23
if (line.ne." 2.92300E+01") call abort
write(line, '(g0.8)') -28.4
if (line.ne."-2.83999996E+01") call abort
write(line, '(g0.8)') -0.0001
if (line.ne."-9.99999975E-05") call abort
end
libgfortran/ChangeLog
2008-09-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/37301
PR libfortran/37228
* io/io.h (write_real_g0): Declare new function to handle g0.d format.
* io/transfer.c (formatted_transfer_scalar): Use new function.
* io/format.c (parse_format_list): Enable g0.d.
* io/write.c (write_a_char4): Delete unused var.
(set_fnode_default): New function to set the default fnode w, d, and e
factored from write_real. (write_real): Use new factored function.
(write_real_g0): New function that sets d to that passed by g0.d format
specifier and set format to ES. Default values for w and e are used
from the new function, set_fnode_default.
2008-09-01 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* runtime/error.c: Fix cast for printf.
2008-08-30 Jerry DeLisle <jvdelisle@gcc.gnu.org>
......
libgfortran/io/format.c
......@@ -735,6 +735,20 @@ parse_format_list (st_parameter_dt *dtp)
goto finished;
}
tail->u.real.w = 0;
u = format_lex (fmt);
if (u != FMT_PERIOD)
{
fmt->saved_token = u;
break;
}
u = format_lex (fmt);
if (u != FMT_POSINT)
{
fmt->error = posint_required;
goto finished;
}
tail->u.real.d = fmt->value;
break;
}
if (t == FMT_F || dtp->u.p.mode == WRITING)
......
libgfortran/io/io.h
......@@ -940,6 +940,9 @@ internal_proto(write_o);
extern void write_real (st_parameter_dt *, const char *, int);
internal_proto(write_real);
extern void write_real_g0 (st_parameter_dt *, const char *, int, int);
internal_proto(write_real_g0);
extern void write_x (st_parameter_dt *, int, int);
internal_proto(write_x);
......
libgfortran/io/transfer.c
......@@ -1213,7 +1213,12 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
break;
case BT_REAL:
if (f->u.real.w == 0)
write_real (dtp, p, kind);
{
if (f->u.real.d == 0)
write_real (dtp, p, kind);
else
write_real_g0 (dtp, p, kind, f->u.real.d);
}
else
write_d (dtp, f, p, kind);
break;
......
libgfortran/io/write.c
......@@ -301,7 +301,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
if (is_stream_io (dtp))
{
const char crlf[] = "\r\n";
int i, j, bytes;
int i, bytes;
gfc_char4_t *qq;
bytes = 0;
......@@ -952,43 +952,64 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
}
/* Output a real number with default format.
This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
/* Set an fnode to default format. */
void
write_real (st_parameter_dt *dtp, const char *source, int length)
static void
set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
{
fnode f ;
int org_scale = dtp->u.p.scale_factor;
f.format = FMT_G;
dtp->u.p.scale_factor = 1;
f->format = FMT_G;
switch (length)
{
case 4:
f.u.real.w = 15;
f.u.real.d = 8;
f.u.real.e = 2;
f->u.real.w = 15;
f->u.real.d = 8;
f->u.real.e = 2;
break;
case 8:
f.u.real.w = 25;
f.u.real.d = 17;
f.u.real.e = 3;
f->u.real.w = 25;
f->u.real.d = 17;
f->u.real.e = 3;
break;
case 10:
f.u.real.w = 29;
f.u.real.d = 20;
f.u.real.e = 4;
f->u.real.w = 29;
f->u.real.d = 20;
f->u.real.e = 4;
break;
case 16:
f.u.real.w = 44;
f.u.real.d = 35;
f.u.real.e = 4;
f->u.real.w = 44;
f->u.real.d = 35;
f->u.real.e = 4;
break;
default:
internal_error (&dtp->common, "bad real kind");
break;
}
}
/* Output a real number with default format.
This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
void
write_real (st_parameter_dt *dtp, const char *source, int length)
{
fnode f ;
int org_scale = dtp->u.p.scale_factor;
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, length);
write_float (dtp, &f, source , length);
dtp->u.p.scale_factor = org_scale;
}
void
write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
{
fnode f ;
int org_scale = dtp->u.p.scale_factor;
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, length);
f.format = FMT_ES;
f.u.real.d = d;
write_float (dtp, &f, source , length);
dtp->u.p.scale_factor = org_scale;
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment