FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/34192 (NEAREST can return wrong numbers)

Browse source 
2007-11-23  Tobias Burnus  <burnus@net-b.de>
            Steven G. Kargl  <kargl@gcc.gnu.org>

        PR fortran/34192
        * simplify.c (gfc_simplify_nearest): Fix NEAREST for
        subnormal numbers.

2007-11-23  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34192
        * gfortran.dg/nearest_2.f90: New.


Co-Authored-By: Steven G. Kargl <kargl@gcc.gnu.org>

From-SVN: r130383
This commit is contained in:
Tobias Burnus 2007-11-23 22:03:48 +01:00 • committed by Tobias Burnus
parent 360f866c16
commit b6f63e8984
4 changed files with 194 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View file

@ -1,3 +1,10 @@
2007-11-23 Tobias Burnus <burnus@net-b.de>
Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/34192
* simplify.c (gfc_simplify_nearest): Fix NEAREST for
subnormal numbers.
2007-11-23 Aldy Hernandez <aldyh@redhat.com>
* trans-expr.c (gfc_trans_string_copy): Use "void *" when building a

42
gcc/fortran/simplify.c
View file

@ -2691,8 +2691,8 @@ gfc_expr *
gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
{
gfc_expr *result;
mpfr_t tmp;
int sgn;
mp_exp_t emin, emax;
int kind;
if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
@ -2707,13 +2707,39 @@ gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
gfc_set_model_kind (x->ts.kind);
result = gfc_copy_expr (x);
sgn = mpfr_sgn (s->value.real);
mpfr_init (tmp);
mpfr_set_inf (tmp, sgn);
mpfr_nexttoward (result->value.real, tmp);
mpfr_clear (tmp);
/* Save current values of emin and emax. */
emin = mpfr_get_emin ();
emax = mpfr_get_emax ();
return range_check (result, "NEAREST");
/* Set emin and emax for the current model number. */
kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
mpfr_set_emin ((mp_exp_t) gfc_real_kinds[kind].min_exponent -
mpfr_get_prec(result->value.real) + 1);
mpfr_set_emax ((mp_exp_t) gfc_real_kinds[kind].max_exponent - 1);
if (mpfr_sgn (s->value.real) > 0)
{
mpfr_nextabove (result->value.real);
mpfr_subnormalize (result->value.real, 0, GMP_RNDU);
}
else
{
mpfr_nextbelow (result->value.real);
mpfr_subnormalize (result->value.real, 0, GMP_RNDD);
}
mpfr_set_emin (emin);
mpfr_set_emax (emax);
/* Only NaN can occur. Do not use range check as it gives an
error for denormal numbers. */
if (mpfr_nan_p (result->value.real) && gfc_option.flag_range_check)
{
gfc_error ("Result of NEAREST is NaN at %L", &result->where);
return &gfc_bad_expr;
}
return result;
}

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2007-11-23 Tobias Burnus <burnus@net-b.de>
PR fortran/34192
* gfortran.dg/nearest_2.f90: New.
2007-11-23 Jakub Jelinek <jakub@redhat.com>
PR c++/30293

147
gcc/testsuite/gfortran.dg/nearest_2.f90 Normal file
View file

@ -0,0 +1,147 @@
! { dg-do run }
!
! PR fortran/34192
!
! Test compile-time implementation of NEAREST
!
program test
implicit none
! Single precision
! 0+ > 0
if (nearest(0.0, 1.0) &
<= 0.0) &
call abort()
! 0++ > 0+
if (nearest(nearest(0.0, 1.0), 1.0) &
<= nearest(0.0, 1.0)) &
call abort()
! 0+++ > 0++
if (nearest(nearest(nearest(0.0, 1.0), 1.0), 1.0) &
<= nearest(nearest(0.0, 1.0), 1.0)) &
call abort()
! 0+- = 0
if (nearest(nearest(0.0, 1.0), -1.0) &
/= 0.0) &
call abort()
! 0++- = 0+
if (nearest(nearest(nearest(0.0, 1.0), 1.0), -1.0) &
/= nearest(0.0, 1.0)) &
call abort()
! 0++-- = 0
if (nearest(nearest(nearest(nearest(0.0, 1.0), 1.0), -1.0), -1.0) &
/= 0.0) &
call abort()
! 0- < 0
if (nearest(0.0, -1.0) &
>= 0.0) &
call abort()
! 0-- < 0+
if (nearest(nearest(0.0, -1.0), -1.0) &
>= nearest(0.0, -1.0)) &
call abort()
! 0--- < 0--
if (nearest(nearest(nearest(0.0, -1.0), -1.0), -1.0) &
>= nearest(nearest(0.0, -1.0), -1.0)) &
call abort()
! 0-+ = 0
if (nearest(nearest(0.0, -1.0), 1.0) &
/= 0.0) &
call abort()
! 0--+ = 0-
if (nearest(nearest(nearest(0.0, -1.0), -1.0), 1.0) &
/= nearest(0.0, -1.0)) &
call abort()
! 0--++ = 0
if (nearest(nearest(nearest(nearest(0.0, -1.0), -1.0), 1.0), 1.0) &
/= 0.0) &
call abort()
! 42++ > 42+
if (nearest(nearest(42.0, 1.0), 1.0) &
<= nearest(42.0, 1.0)) &
call abort()
! 42-- < 42-
if (nearest(nearest(42.0, -1.0), -1.0) &
>= nearest(42.0, -1.0)) &
call abort()
! 42-+ = 42
if (nearest(nearest(42.0, -1.0), 1.0) &
/= 42.0) &
call abort()
! 42+- = 42
if (nearest(nearest(42.0, 1.0), -1.0) &
/= 42.0) &
call abort()
! Double precision
! 0+ > 0
if (nearest(0.0d0, 1.0) &
<= 0.0d0) &
call abort()
! 0++ > 0+
if (nearest(nearest(0.0d0, 1.0), 1.0) &
<= nearest(0.0d0, 1.0)) &
call abort()
! 0+++ > 0++
if (nearest(nearest(nearest(0.0d0, 1.0), 1.0), 1.0) &
<= nearest(nearest(0.0d0, 1.0), 1.0)) &
call abort()
! 0+- = 0
if (nearest(nearest(0.0d0, 1.0), -1.0) &
/= 0.0d0) &
call abort()
! 0++- = 0+
if (nearest(nearest(nearest(0.0d0, 1.0), 1.0), -1.0) &
/= nearest(0.0d0, 1.0)) &
call abort()
! 0++-- = 0
if (nearest(nearest(nearest(nearest(0.0d0, 1.0), 1.0), -1.0), -1.0) &
/= 0.0d0) &
call abort()
! 0- < 0
if (nearest(0.0d0, -1.0) &
>= 0.0d0) &
call abort()
! 0-- < 0+
if (nearest(nearest(0.0d0, -1.0), -1.0) &
>= nearest(0.0d0, -1.0)) &
call abort()
! 0--- < 0--
if (nearest(nearest(nearest(0.0d0, -1.0), -1.0), -1.0) &
>= nearest(nearest(0.0d0, -1.0), -1.0)) &
call abort()
! 0-+ = 0
if (nearest(nearest(0.0d0, -1.0), 1.0) &
/= 0.0d0) &
call abort()
! 0--+ = 0-
if (nearest(nearest(nearest(0.0d0, -1.0), -1.0), 1.0) &
/= nearest(0.0d0, -1.0)) &
call abort()
! 0--++ = 0
if (nearest(nearest(nearest(nearest(0.0d0, -1.0), -1.0), 1.0), 1.0) &
/= 0.0d0) &
call abort()
! 42++ > 42+
if (nearest(nearest(42.0d0, 1.0), 1.0) &
<= nearest(42.0d0, 1.0)) &
call abort()
! 42-- < 42-
if (nearest(nearest(42.0d0, -1.0), -1.0) &
>= nearest(42.0d0, -1.0)) &
call abort()
! 42-+ = 42
if (nearest(nearest(42.0d0, -1.0), 1.0) &
/= 42.0d0) &
call abort()
! 42+- = 42
if (nearest(nearest(42.0d0, 1.0), -1.0) &
/= 42.0d0) &
call abort()
end program test