re PR fortran/64022 ([F2003][IEEE] ieee_support_flag does not handle kind=10 and kind=16 REAL variables)
PR fortran/64022 * simplify.c (gfc_simplify_ieee_selected_real_kind): Extend IEEE support to all real kinds. * ieee/ieee_exceptions.F90: Support all real kinds. * ieee/ieee_arithmetic.F90: Likewise. * ieee/ieee_helper.c (ieee_class_helper_10, ieee_class_helper_16): New functions * gfortran.map (GFORTRAN_1.7): Add entries. * gfortran.dg/ieee/ieee_7.f90: Adjust test. * gfortran.dg/ieee/large_1.f90: New test. From-SVN: r226548
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
0ad23163d0
commit
22a499884f
|
|
@ -1,3 +1,9 @@
|
|||
2015-08-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64022
|
||||
* simplify.c (gfc_simplify_ieee_selected_real_kind): Extend IEEE
|
||||
support to all real kinds.
|
||||
|
||||
2015-08-03 Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
PR fortran/66942
|
||||
|
|
|
|||
|
|
@ -5556,80 +5556,13 @@ gfc_expr *
|
|||
gfc_simplify_ieee_selected_real_kind (gfc_expr *expr)
|
||||
{
|
||||
gfc_actual_arglist *arg = expr->value.function.actual;
|
||||
gfc_expr *p = arg->expr, *r = arg->next->expr,
|
||||
*rad = arg->next->next->expr;
|
||||
int precision, range, radix, res;
|
||||
int found_precision, found_range, found_radix, i;
|
||||
gfc_expr *p = arg->expr, *q = arg->next->expr,
|
||||
*rdx = arg->next->next->expr;
|
||||
|
||||
if (p)
|
||||
{
|
||||
if (p->expr_type != EXPR_CONSTANT
|
||||
|| gfc_extract_int (p, &precision) != NULL)
|
||||
return NULL;
|
||||
}
|
||||
else
|
||||
precision = 0;
|
||||
|
||||
if (r)
|
||||
{
|
||||
if (r->expr_type != EXPR_CONSTANT
|
||||
|| gfc_extract_int (r, &range) != NULL)
|
||||
return NULL;
|
||||
}
|
||||
else
|
||||
range = 0;
|
||||
|
||||
if (rad)
|
||||
{
|
||||
if (rad->expr_type != EXPR_CONSTANT
|
||||
|| gfc_extract_int (rad, &radix) != NULL)
|
||||
return NULL;
|
||||
}
|
||||
else
|
||||
radix = 0;
|
||||
|
||||
res = INT_MAX;
|
||||
found_precision = 0;
|
||||
found_range = 0;
|
||||
found_radix = 0;
|
||||
|
||||
for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
||||
{
|
||||
/* We only support the target's float and double types. */
|
||||
if (!gfc_real_kinds[i].c_float && !gfc_real_kinds[i].c_double)
|
||||
continue;
|
||||
|
||||
if (gfc_real_kinds[i].precision >= precision)
|
||||
found_precision = 1;
|
||||
|
||||
if (gfc_real_kinds[i].range >= range)
|
||||
found_range = 1;
|
||||
|
||||
if (radix == 0 || gfc_real_kinds[i].radix == radix)
|
||||
found_radix = 1;
|
||||
|
||||
if (gfc_real_kinds[i].precision >= precision
|
||||
&& gfc_real_kinds[i].range >= range
|
||||
&& (radix == 0 || gfc_real_kinds[i].radix == radix)
|
||||
&& gfc_real_kinds[i].kind < res)
|
||||
res = gfc_real_kinds[i].kind;
|
||||
}
|
||||
|
||||
if (res == INT_MAX)
|
||||
{
|
||||
if (found_radix && found_range && !found_precision)
|
||||
res = -1;
|
||||
else if (found_radix && found_precision && !found_range)
|
||||
res = -2;
|
||||
else if (found_radix && !found_precision && !found_range)
|
||||
res = -3;
|
||||
else if (found_radix)
|
||||
res = -4;
|
||||
else
|
||||
res = -5;
|
||||
}
|
||||
|
||||
return gfc_get_int_expr (gfc_default_integer_kind, &expr->where, res);
|
||||
/* Currently, if IEEE is supported and this module is built, it means
|
||||
all our floating-point types conform to IEEE. Hence, we simply handle
|
||||
IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
|
||||
return gfc_simplify_selected_real_kind (p, q, rdx);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2015-08-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64022
|
||||
* gfortran.dg/ieee/ieee_7.f90: Adjust test.
|
||||
* gfortran.dg/ieee/large_1.f90: New test.
|
||||
|
||||
2015-08-04 Thomas Preud'homme <thomas.preudhomme@arm.com>
|
||||
|
||||
PR tree-optimization/67043
|
||||
|
|
|
|||
|
|
@ -1,8 +1,14 @@
|
|||
! { dg-do run }
|
||||
|
||||
use :: ieee_arithmetic
|
||||
use :: iso_fortran_env, only : real_kinds
|
||||
implicit none
|
||||
|
||||
! This should be
|
||||
! integer, parameter :: maxreal = maxval(real_kinds)
|
||||
! but it works because REAL_KINDS happen to be in increasing order
|
||||
integer, parameter :: maxreal = real_kinds(size(real_kinds))
|
||||
|
||||
! Test IEEE_SELECTED_REAL_KIND in specification expressions
|
||||
|
||||
integer(kind=ieee_selected_real_kind()) :: i1
|
||||
|
|
@ -27,8 +33,8 @@
|
|||
end if
|
||||
|
||||
if (ieee_selected_real_kind(0,0,3) /= -5) call abort
|
||||
if (ieee_selected_real_kind(precision(0.d0)+1) /= -1) call abort
|
||||
if (ieee_selected_real_kind(0,range(0.d0)+1) /= -2) call abort
|
||||
if (ieee_selected_real_kind(precision(0.d0)+1,range(0.d0)+1) /= -3) call abort
|
||||
if (ieee_selected_real_kind(precision(0._maxreal)+1) /= -1) call abort
|
||||
if (ieee_selected_real_kind(0,range(0._maxreal)+1) /= -2) call abort
|
||||
if (ieee_selected_real_kind(precision(0._maxreal)+1,range(0._maxreal)+1) /= -3) call abort
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -0,0 +1,138 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Testing IEEE modules on large real kinds
|
||||
|
||||
program test
|
||||
|
||||
use ieee_arithmetic
|
||||
implicit none
|
||||
|
||||
! k1 and k2 will be large real kinds, if supported, and single/double
|
||||
! otherwise
|
||||
integer, parameter :: k1 = &
|
||||
max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
|
||||
integer, parameter :: k2 = &
|
||||
max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
|
||||
|
||||
real(kind=k1) :: x1, y1
|
||||
real(kind=k2) :: x2, y2
|
||||
|
||||
! Checking ieee_is_finite
|
||||
|
||||
if (.not. ieee_is_finite(huge(0._k1))) call abort
|
||||
if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) call abort
|
||||
x1 = -42
|
||||
if (.not. ieee_is_finite(x1)) call abort
|
||||
if (ieee_is_finite(sqrt(x1))) call abort
|
||||
|
||||
if (.not. ieee_is_finite(huge(0._k2))) call abort
|
||||
if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) call abort
|
||||
x2 = -42
|
||||
if (.not. ieee_is_finite(x2)) call abort
|
||||
if (ieee_is_finite(sqrt(x2))) call abort
|
||||
|
||||
! Other ieee_is intrinsics
|
||||
|
||||
if (ieee_is_nan(huge(0._k1))) call abort
|
||||
if (.not. ieee_is_negative(-huge(0._k1))) call abort
|
||||
if (.not. ieee_is_normal(-huge(0._k1))) call abort
|
||||
|
||||
if (ieee_is_nan(huge(0._k2))) call abort
|
||||
if (.not. ieee_is_negative(-huge(0._k2))) call abort
|
||||
if (.not. ieee_is_normal(-huge(0._k2))) call abort
|
||||
|
||||
! ieee_support intrinsics
|
||||
|
||||
if (.not. ieee_support_datatype(x1)) call abort
|
||||
if (.not. ieee_support_denormal(x1)) call abort
|
||||
if (.not. ieee_support_divide(x1)) call abort
|
||||
if (.not. ieee_support_inf(x1)) call abort
|
||||
if (.not. ieee_support_io(x1)) call abort
|
||||
if (.not. ieee_support_nan(x1)) call abort
|
||||
if (.not. ieee_support_rounding(ieee_nearest, x1)) call abort
|
||||
if (.not. ieee_support_sqrt(x1)) call abort
|
||||
if (.not. ieee_support_standard(x1)) call abort
|
||||
if (.not. ieee_support_underflow_control(x1)) call abort
|
||||
|
||||
if (.not. ieee_support_datatype(x2)) call abort
|
||||
if (.not. ieee_support_denormal(x2)) call abort
|
||||
if (.not. ieee_support_divide(x2)) call abort
|
||||
if (.not. ieee_support_inf(x2)) call abort
|
||||
if (.not. ieee_support_io(x2)) call abort
|
||||
if (.not. ieee_support_nan(x2)) call abort
|
||||
if (.not. ieee_support_rounding(ieee_nearest, x2)) call abort
|
||||
if (.not. ieee_support_sqrt(x2)) call abort
|
||||
if (.not. ieee_support_standard(x2)) call abort
|
||||
if (.not. ieee_support_underflow_control(x2)) call abort
|
||||
|
||||
! ieee_value and ieee_class
|
||||
|
||||
if (.not. ieee_is_nan(ieee_value(x1, ieee_quiet_nan))) call abort
|
||||
if (ieee_class(ieee_value(x1, ieee_positive_denormal)) &
|
||||
/= ieee_positive_denormal) call abort
|
||||
|
||||
if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) call abort
|
||||
if (ieee_class(ieee_value(x2, ieee_positive_denormal)) &
|
||||
/= ieee_positive_denormal) call abort
|
||||
|
||||
! ieee_unordered
|
||||
|
||||
if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) call abort
|
||||
if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) call abort
|
||||
|
||||
if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) call abort
|
||||
if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) call abort
|
||||
|
||||
! ieee_copy_sign
|
||||
|
||||
if (.not. ieee_class(ieee_copy_sign(ieee_value(x1, ieee_positive_inf), -1.)) &
|
||||
== ieee_negative_inf) call abort
|
||||
if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) &
|
||||
== ieee_negative_zero) call abort
|
||||
|
||||
if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) &
|
||||
== ieee_negative_inf) call abort
|
||||
if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) &
|
||||
== ieee_negative_zero) call abort
|
||||
|
||||
! ieee_logb
|
||||
|
||||
if (ieee_logb (42._k1) /= exponent(42._k1) - 1) call abort
|
||||
|
||||
if (ieee_logb (42._k2) /= exponent(42._k2) - 1) call abort
|
||||
|
||||
! ieee_next_after
|
||||
|
||||
if (ieee_next_after(42._k1, ieee_value(x1, ieee_positive_inf)) &
|
||||
/= 42._k1 + spacing(42._k1)) call abort
|
||||
|
||||
if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) &
|
||||
/= 42._k2 + spacing(42._k2)) call abort
|
||||
|
||||
! ieee_rem
|
||||
|
||||
if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) &
|
||||
call abort
|
||||
|
||||
if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) &
|
||||
call abort
|
||||
|
||||
! ieee_rint
|
||||
|
||||
if (ieee_rint(-1.1_k1) /= -1._k1) call abort
|
||||
if (ieee_rint(huge(x1)) /= huge(x1)) call abort
|
||||
|
||||
if (ieee_rint(-1.1_k2) /= -1._k2) call abort
|
||||
if (ieee_rint(huge(x2)) /= huge(x2)) call abort
|
||||
|
||||
! ieee_scalb
|
||||
|
||||
x1 = sqrt(42._k1)
|
||||
if (ieee_scalb(x1, 2) /= 4._k1 * x1) call abort
|
||||
if (ieee_scalb(x1, -2) /= x1 / 4._k1) call abort
|
||||
|
||||
x2 = sqrt(42._k2)
|
||||
if (ieee_scalb(x2, 2) /= 4._k2 * x2) call abort
|
||||
if (ieee_scalb(x2, -2) /= x2 / 4._k2) call abort
|
||||
|
||||
end program test
|
||||
|
|
@ -1,3 +1,12 @@
|
|||
2015-08-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64022
|
||||
* ieee/ieee_exceptions.F90: Support all real kinds.
|
||||
* ieee/ieee_arithmetic.F90: Likewise.
|
||||
* ieee/ieee_helper.c (ieee_class_helper_10,
|
||||
ieee_class_helper_16): New functions
|
||||
* gfortran.map (GFORTRAN_1.7): Add entries.
|
||||
|
||||
2015-07-29 Uros Bizjak <ubizjak@gmail.com>
|
||||
|
||||
PR libgfortran/66650
|
||||
|
|
|
|||
|
|
@ -1276,6 +1276,16 @@ GFORTRAN_1.6 {
|
|||
__ieee_exceptions_MOD_ieee_usual;
|
||||
} GFORTRAN_1.5;
|
||||
|
||||
GFORTRAN_1.7 {
|
||||
global:
|
||||
__ieee_arithmetic_MOD_ieee_class_10;
|
||||
__ieee_arithmetic_MOD_ieee_class_16;
|
||||
__ieee_arithmetic_MOD_ieee_value_10;
|
||||
__ieee_arithmetic_MOD_ieee_value_16;
|
||||
__ieee_exceptions_MOD_ieee_support_flag_10;
|
||||
__ieee_exceptions_MOD_ieee_support_flag_16;
|
||||
} GFORTRAN_1.6;
|
||||
|
||||
F2C_1.0 {
|
||||
global:
|
||||
_gfortran_f2c_specific__abs_c4;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -57,9 +57,15 @@ module IEEE_EXCEPTIONS
|
|||
end type
|
||||
|
||||
interface IEEE_SUPPORT_FLAG
|
||||
module procedure IEEE_SUPPORT_FLAG_NOARG, &
|
||||
IEEE_SUPPORT_FLAG_4, &
|
||||
IEEE_SUPPORT_FLAG_8
|
||||
module procedure IEEE_SUPPORT_FLAG_4, &
|
||||
IEEE_SUPPORT_FLAG_8, &
|
||||
#ifdef HAVE_GFC_REAL_10
|
||||
IEEE_SUPPORT_FLAG_10, &
|
||||
#endif
|
||||
#ifdef HAVE_GFC_REAL_16
|
||||
IEEE_SUPPORT_FLAG_16, &
|
||||
#endif
|
||||
IEEE_SUPPORT_FLAG_NOARG
|
||||
end interface IEEE_SUPPORT_FLAG
|
||||
|
||||
public :: IEEE_SUPPORT_FLAG, IEEE_SUPPORT_HALTING
|
||||
|
|
@ -215,4 +221,22 @@ contains
|
|||
res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
||||
end function
|
||||
|
||||
#ifdef HAVE_GFC_REAL_10
|
||||
pure logical function IEEE_SUPPORT_FLAG_10 (FLAG, X) result(res)
|
||||
implicit none
|
||||
type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
||||
real(kind=10), intent(in) :: X
|
||||
res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
||||
end function
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_GFC_REAL_16
|
||||
pure logical function IEEE_SUPPORT_FLAG_16 (FLAG, X) result(res)
|
||||
implicit none
|
||||
type(IEEE_FLAG_TYPE), intent(in) :: FLAG
|
||||
real(kind=16), intent(in) :: X
|
||||
res = IEEE_SUPPORT_FLAG_NOARG(FLAG)
|
||||
end function
|
||||
#endif
|
||||
|
||||
end module IEEE_EXCEPTIONS
|
||||
|
|
|
|||
|
|
@ -33,6 +33,16 @@ internal_proto(ieee_class_helper_4);
|
|||
extern int ieee_class_helper_8 (GFC_REAL_8 *);
|
||||
internal_proto(ieee_class_helper_8);
|
||||
|
||||
#ifdef HAVE_GFC_REAL_10
|
||||
extern int ieee_class_helper_10 (GFC_REAL_10 *);
|
||||
internal_proto(ieee_class_helper_10);
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_GFC_REAL_16
|
||||
extern int ieee_class_helper_16 (GFC_REAL_16 *);
|
||||
internal_proto(ieee_class_helper_16);
|
||||
#endif
|
||||
|
||||
/* Enumeration of the possible floating-point types. These values
|
||||
correspond to the hidden arguments of the IEEE_CLASS_TYPE
|
||||
derived-type of IEEE_ARITHMETIC. */
|
||||
|
|
@ -74,6 +84,14 @@ enum { IEEE_OTHER_VALUE = 0, IEEE_SIGNALING_NAN, IEEE_QUIET_NAN,
|
|||
CLASSMACRO(4)
|
||||
CLASSMACRO(8)
|
||||
|
||||
#ifdef HAVE_GFC_REAL_10
|
||||
CLASSMACRO(10)
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_GFC_REAL_16
|
||||
CLASSMACRO(16)
|
||||
#endif
|
||||
|
||||
|
||||
#define GFC_FPE_ALL (GFC_FPE_INVALID | GFC_FPE_DENORMAL | \
|
||||
GFC_FPE_ZERO | GFC_FPE_OVERFLOW | \
|
||||
|
|
|
|||
Loading…
Reference in New Issue