Hi Folks,
This patch implements the adjustments required for the various rounding modes as
stated in the Fortran Standard F2008, paragraph 10.7.5.2.2. In the process of
testing this patch we have found another bug related to D and E editing which is
now PR48651. In the meantime, this regressions tests fine on x86-64.
Test case is that provided in the PR.
OK for trunk?
Regards,
Jerry
2011-04-17 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR libgfortran/48602
* io/write_float.def (output_float_FMT_G): Use current rounding mode
to set the rounding parameters. (output_float): Skip rounding
if value is zero.
Index: write_float.def
===================================================================
--- write_float.def (revision 172502)
+++ write_float.def (working copy)
@@ -221,6 +221,8 @@ output_float (st_parameter_dt *dtp, const fnode *f
internal_error (&dtp->common, "Unexpected format token");
}
+ if (zero_flag)
+ goto skip;
/* Round the value. The value being rounded is an unsigned magnitude.
The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
switch (dtp->u.p.current_unit->round_status)
@@ -810,7 +812,8 @@ CALCULATE_EXP(16)
m >= 10**d-0.5 Ew.d[Ee]
notes: for Gw.d , n' ' means 4 blanks
- for Gw.dEe, n' ' means e+2 blanks */
+ for Gw.dEe, n' ' means e+2 blanks
+ for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2 */
#define OUTPUT_FLOAT_FMT_G(x) \
static void \
@@ -822,7 +825,7 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
int d = f->u.real.d;\
int w = f->u.real.w;\
fnode *newf;\
- GFC_REAL_ ## x rexp_d;\
+ GFC_REAL_ ## x rexp_d, r = 0.5;\
int low, high, mid;\
int ubound, lbound;\
char *p, pad = ' ';\
@@ -832,9 +835,25 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
save_scale_factor = dtp->u.p.scale_factor;\
newf = (fnode *) get_mem (sizeof (fnode));\
\
+ switch (dtp->u.p.current_unit->round_status)\
+ {\
+ case ROUND_ZERO:\
+ r = sign_bit ? 0.0 : 1.0;\
+ break;\
+ case ROUND_UP:\
+ r = 1.0;\
+ break;\
+ case ROUND_DOWN:\
+ r = 0.0;\
+ break;\
+ default:\
+ break;\
+ }\
+\
rexp_d = calculate_exp_ ## x (-d);\
- if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
- ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
+ if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\
+ || ((m == 0.0) && !(compile_options.allow_std\
+ & (GFC_STD_F2003 | GFC_STD_F2008))))\
{ \
newf->format = FMT_E;\
newf->u.real.w = w;\
@@ -855,7 +874,7 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
GFC_REAL_ ## x temp;\
mid = (low + high) / 2;\
\
- temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
+ temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
\
if (m < temp)\
{ \
! { dg-do run }
! PE48602 Invalid F conversion of G descriptor for values close to powers of 10
! Test case provided by Thomas Henlich
program test_g0fr
use iso_fortran_env
implicit none
integer, parameter :: RT = REAL64
call check_all(0.0_RT, 15, 2, 0)
call check_all(0.991_RT, 15, 2, 0)
call check_all(0.995_RT, 15, 2, 0)
call check_all(0.996_RT, 15, 2, 0)
call check_all(0.999_RT, 15, 2, 0)
contains
subroutine check_all(val, w, d, e)
real(kind=RT), intent(in) :: val
integer, intent(in) :: w
integer, intent(in) :: d
integer, intent(in) :: e
call check_f_fmt(val, 'C', w, d, e)
call check_f_fmt(val, 'U', w, d, e)
call check_f_fmt(val, 'D', w, d, e)
end subroutine check_all
subroutine check_f_fmt(val, roundmode, w, d, e)
real(kind=RT), intent(in) :: val
character, intent(in) :: roundmode
integer, intent(in) :: w
integer, intent(in) :: d
integer, intent(in) :: e
character(len=80) :: fmt_f, fmt_g
character(len=80) :: s_f, s_g
real(kind=RT) :: mag, lower, upper
real(kind=RT) :: r
integer :: n, dec
mag = abs(val)
if (e == 0) then
n = 4
else
n = e + 2
end if
select case (roundmode)
case('U')
r = 1.0_RT
case('D')
r = 0.0_RT
case('C')
r = 0.5_RT
end select
if (mag == 0) then
write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')")
roundmode, w - n, d - 1, n
else
do dec = d, 0, -1
lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)
upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)
if (lower <= mag .and. mag < upper) then
write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')")
roundmode, w - n, dec, n
exit
end if
end do
end if
if (len_trim(fmt_f) == 0) then
! e editing
return
end if
if (e == 0) then
write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d
else
write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w,
d, e
end if
write(s_g, "('''', " // trim(fmt_g) // ",'''')") val
write(s_f, "('''', " // trim(fmt_f) // ",'''')") val
if (s_g /= s_f) call abort
!if (s_g /= s_f) then
!print "(a,g0,a,g0)", "lower=", lower, " upper=", upper
! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g),
trim(s_f), trim(fmt_g), trim(fmt_f), val
!end if
end subroutine check_f_fmt
end program test_g0fr
