From 22a499884f31391a6ab02739861b2b343eebc94e Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Tue, 4 Aug 2015 07:27:19 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 6 + gcc/fortran/simplify.c | 79 +-- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 | 12 +- gcc/testsuite/gfortran.dg/ieee/large_1.f90 | 138 ++++ libgfortran/ChangeLog | 9 + libgfortran/gfortran.map | 10 + libgfortran/ieee/ieee_arithmetic.F90 | 760 ++++++++++++++++----- libgfortran/ieee/ieee_exceptions.F90 | 30 +- libgfortran/ieee/ieee_helper.c | 18 + 10 files changed, 811 insertions(+), 257 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/ieee/large_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 36cd6f3b4cd..46f9a927938 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-08-04 Francois-Xavier Coudert + + PR fortran/64022 + * simplify.c (gfc_simplify_ieee_selected_real_kind): Extend IEEE + support to all real kinds. + 2015-08-03 Steven G. Kargl PR fortran/66942 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 3fb98873709..f0fdfbdfa0d 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ae404d30409..3a9143d09c1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2015-08-04 Francois-Xavier Coudert + + 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 PR tree-optimization/67043 diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 index a66e9057bec..227bf544cc1 100644 --- a/gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 +++ b/gcc/testsuite/gfortran.dg/ieee/ieee_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ieee/large_1.f90 b/gcc/testsuite/gfortran.dg/ieee/large_1.f90 new file mode 100644 index 00000000000..5ec2dab2d05 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/large_1.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 29efe0ad486..e74bff61dac 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2015-08-04 Francois-Xavier Coudert + + 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 PR libgfortran/66650 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index cfbfb160a52..73cdde78571 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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; diff --git a/libgfortran/ieee/ieee_arithmetic.F90 b/libgfortran/ieee/ieee_arithmetic.F90 index f81a4f89e13..89456cf1550 100644 --- a/libgfortran/ieee/ieee_arithmetic.F90 +++ b/libgfortran/ieee/ieee_arithmetic.F90 @@ -95,10 +95,27 @@ module IEEE_ARITHMETIC elemental logical function _gfortran_ieee_is_finite_8(X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental logical function _gfortran_ieee_is_finite_10(X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental logical function _gfortran_ieee_is_finite_16(X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_IS_FINITE - procedure _gfortran_ieee_is_finite_4, _gfortran_ieee_is_finite_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_is_finite_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_is_finite_10, & +#endif + _gfortran_ieee_is_finite_8, _gfortran_ieee_is_finite_4 end interface public :: IEEE_IS_FINITE @@ -111,10 +128,27 @@ module IEEE_ARITHMETIC elemental logical function _gfortran_ieee_is_nan_8(X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental logical function _gfortran_ieee_is_nan_10(X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental logical function _gfortran_ieee_is_nan_16(X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_IS_NAN - procedure _gfortran_ieee_is_nan_4, _gfortran_ieee_is_nan_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_is_nan_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_is_nan_10, & +#endif + _gfortran_ieee_is_nan_8, _gfortran_ieee_is_nan_4 end interface public :: IEEE_IS_NAN @@ -127,10 +161,27 @@ module IEEE_ARITHMETIC elemental logical function _gfortran_ieee_is_negative_8(X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental logical function _gfortran_ieee_is_negative_10(X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental logical function _gfortran_ieee_is_negative_16(X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_IS_NEGATIVE - procedure _gfortran_ieee_is_negative_4, _gfortran_ieee_is_negative_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_is_negative_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_is_negative_10, & +#endif + _gfortran_ieee_is_negative_8, _gfortran_ieee_is_negative_4 end interface public :: IEEE_IS_NEGATIVE @@ -143,64 +194,189 @@ module IEEE_ARITHMETIC elemental logical function _gfortran_ieee_is_normal_8(X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental logical function _gfortran_ieee_is_normal_10(X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental logical function _gfortran_ieee_is_normal_16(X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_IS_NORMAL - procedure _gfortran_ieee_is_normal_4, _gfortran_ieee_is_normal_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_is_normal_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_is_normal_10, & +#endif + _gfortran_ieee_is_normal_8, _gfortran_ieee_is_normal_4 end interface public :: IEEE_IS_NORMAL ! IEEE_COPY_SIGN +#define COPYSIGN_MACRO(A,B) \ + elemental real(kind = A) function \ + _gfortran_ieee_copy_sign_/**/A/**/_/**/B (X,Y) ; \ + real(kind = A), intent(in) :: X ; \ + real(kind = B), intent(in) :: Y ; \ + end function + interface - elemental real(kind=4) function _gfortran_ieee_copy_sign_4_4 (X,Y) - real(kind=4), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=4) function _gfortran_ieee_copy_sign_4_8 (X,Y) - real(kind=4), intent(in) :: X - real(kind=8), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_copy_sign_8_4 (X,Y) - real(kind=8), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_copy_sign_8_8 (X,Y) - real(kind=8), intent(in) :: X - real(kind=8), intent(in) :: Y - end function +COPYSIGN_MACRO(4,4) +COPYSIGN_MACRO(4,8) +#ifdef HAVE_GFC_REAL_10 +COPYSIGN_MACRO(4,10) +#endif +#ifdef HAVE_GFC_REAL_16 +COPYSIGN_MACRO(4,16) +#endif +COPYSIGN_MACRO(8,4) +COPYSIGN_MACRO(8,8) +#ifdef HAVE_GFC_REAL_10 +COPYSIGN_MACRO(8,10) +#endif +#ifdef HAVE_GFC_REAL_16 +COPYSIGN_MACRO(8,16) +#endif +#ifdef HAVE_GFC_REAL_10 +COPYSIGN_MACRO(10,4) +COPYSIGN_MACRO(10,8) +COPYSIGN_MACRO(10,10) +#ifdef HAVE_GFC_REAL_16 +COPYSIGN_MACRO(10,16) +#endif +#endif +#ifdef HAVE_GFC_REAL_16 +COPYSIGN_MACRO(16,4) +COPYSIGN_MACRO(16,8) +#ifdef HAVE_GFC_REAL_10 +COPYSIGN_MACRO(16,10) +#endif +COPYSIGN_MACRO(16,16) +#endif end interface interface IEEE_COPY_SIGN - procedure _gfortran_ieee_copy_sign_4_4, _gfortran_ieee_copy_sign_4_8, & - _gfortran_ieee_copy_sign_8_4, _gfortran_ieee_copy_sign_8_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_copy_sign_16_16, & +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_copy_sign_16_10, & +#endif + _gfortran_ieee_copy_sign_16_8, & + _gfortran_ieee_copy_sign_16_4, & +#endif +#ifdef HAVE_GFC_REAL_10 +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_copy_sign_10_16, & +#endif + _gfortran_ieee_copy_sign_10_10, & + _gfortran_ieee_copy_sign_10_8, & + _gfortran_ieee_copy_sign_10_4, & +#endif +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_copy_sign_8_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_copy_sign_8_10, & +#endif + _gfortran_ieee_copy_sign_8_8, & + _gfortran_ieee_copy_sign_8_4, & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_copy_sign_4_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_copy_sign_4_10, & +#endif + _gfortran_ieee_copy_sign_4_8, & + _gfortran_ieee_copy_sign_4_4 end interface public :: IEEE_COPY_SIGN ! IEEE_UNORDERED +#define UNORDERED_MACRO(A,B) \ + elemental logical function \ + _gfortran_ieee_unordered_/**/A/**/_/**/B (X,Y) ; \ + real(kind = A), intent(in) :: X ; \ + real(kind = B), intent(in) :: Y ; \ + end function + interface - elemental logical function _gfortran_ieee_unordered_4_4 (X,Y) - real(kind=4), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental logical function _gfortran_ieee_unordered_4_8 (X,Y) - real(kind=4), intent(in) :: X - real(kind=8), intent(in) :: Y - end function - elemental logical function _gfortran_ieee_unordered_8_4 (X,Y) - real(kind=8), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental logical function _gfortran_ieee_unordered_8_8 (X,Y) - real(kind=8), intent(in) :: X - real(kind=8), intent(in) :: Y - end function +UNORDERED_MACRO(4,4) +UNORDERED_MACRO(4,8) +#ifdef HAVE_GFC_REAL_10 +UNORDERED_MACRO(4,10) +#endif +#ifdef HAVE_GFC_REAL_16 +UNORDERED_MACRO(4,16) +#endif +UNORDERED_MACRO(8,4) +UNORDERED_MACRO(8,8) +#ifdef HAVE_GFC_REAL_10 +UNORDERED_MACRO(8,10) +#endif +#ifdef HAVE_GFC_REAL_16 +UNORDERED_MACRO(8,16) +#endif +#ifdef HAVE_GFC_REAL_10 +UNORDERED_MACRO(10,4) +UNORDERED_MACRO(10,8) +UNORDERED_MACRO(10,10) +#ifdef HAVE_GFC_REAL_16 +UNORDERED_MACRO(10,16) +#endif +#endif +#ifdef HAVE_GFC_REAL_16 +UNORDERED_MACRO(16,4) +UNORDERED_MACRO(16,8) +#ifdef HAVE_GFC_REAL_10 +UNORDERED_MACRO(16,10) +#endif +UNORDERED_MACRO(16,16) +#endif end interface interface IEEE_UNORDERED - procedure _gfortran_ieee_unordered_4_4, _gfortran_ieee_unordered_4_8, & - _gfortran_ieee_unordered_8_4, _gfortran_ieee_unordered_8_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_unordered_16_16, & +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_unordered_16_10, & +#endif + _gfortran_ieee_unordered_16_8, & + _gfortran_ieee_unordered_16_4, & +#endif +#ifdef HAVE_GFC_REAL_10 +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_unordered_10_16, & +#endif + _gfortran_ieee_unordered_10_10, & + _gfortran_ieee_unordered_10_8, & + _gfortran_ieee_unordered_10_4, & +#endif +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_unordered_8_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_unordered_8_10, & +#endif + _gfortran_ieee_unordered_8_8, & + _gfortran_ieee_unordered_8_4, & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_unordered_4_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_unordered_4_10, & +#endif + _gfortran_ieee_unordered_4_8, & + _gfortran_ieee_unordered_4_4 end interface public :: IEEE_UNORDERED @@ -213,64 +389,190 @@ module IEEE_ARITHMETIC elemental real(kind=8) function _gfortran_ieee_logb_8 (X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental real(kind=10) function _gfortran_ieee_logb_10 (X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental real(kind=16) function _gfortran_ieee_logb_16 (X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_LOGB - procedure _gfortran_ieee_logb_4, _gfortran_ieee_logb_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_logb_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_logb_10, & +#endif + _gfortran_ieee_logb_8, & + _gfortran_ieee_logb_4 end interface public :: IEEE_LOGB ! IEEE_NEXT_AFTER +#define NEXT_AFTER_MACRO(A,B) \ + elemental real(kind = A) function \ + _gfortran_ieee_next_after_/**/A/**/_/**/B (X,Y) ; \ + real(kind = A), intent(in) :: X ; \ + real(kind = B), intent(in) :: Y ; \ + end function + interface - elemental real(kind=4) function _gfortran_ieee_next_after_4_4 (X, Y) - real(kind=4), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=4) function _gfortran_ieee_next_after_4_8 (X, Y) - real(kind=4), intent(in) :: X - real(kind=8), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_next_after_8_4 (X, Y) - real(kind=8), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_next_after_8_8 (X, Y) - real(kind=8), intent(in) :: X - real(kind=8), intent(in) :: Y - end function +NEXT_AFTER_MACRO(4,4) +NEXT_AFTER_MACRO(4,8) +#ifdef HAVE_GFC_REAL_10 +NEXT_AFTER_MACRO(4,10) +#endif +#ifdef HAVE_GFC_REAL_16 +NEXT_AFTER_MACRO(4,16) +#endif +NEXT_AFTER_MACRO(8,4) +NEXT_AFTER_MACRO(8,8) +#ifdef HAVE_GFC_REAL_10 +NEXT_AFTER_MACRO(8,10) +#endif +#ifdef HAVE_GFC_REAL_16 +NEXT_AFTER_MACRO(8,16) +#endif +#ifdef HAVE_GFC_REAL_10 +NEXT_AFTER_MACRO(10,4) +NEXT_AFTER_MACRO(10,8) +NEXT_AFTER_MACRO(10,10) +#ifdef HAVE_GFC_REAL_16 +NEXT_AFTER_MACRO(10,16) +#endif +#endif +#ifdef HAVE_GFC_REAL_16 +NEXT_AFTER_MACRO(16,4) +NEXT_AFTER_MACRO(16,8) +#ifdef HAVE_GFC_REAL_10 +NEXT_AFTER_MACRO(16,10) +#endif +NEXT_AFTER_MACRO(16,16) +#endif end interface interface IEEE_NEXT_AFTER - procedure _gfortran_ieee_next_after_4_4, _gfortran_ieee_next_after_4_8, & - _gfortran_ieee_next_after_8_4, _gfortran_ieee_next_after_8_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_next_after_16_16, & +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_next_after_16_10, & +#endif + _gfortran_ieee_next_after_16_8, & + _gfortran_ieee_next_after_16_4, & +#endif +#ifdef HAVE_GFC_REAL_10 +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_next_after_10_16, & +#endif + _gfortran_ieee_next_after_10_10, & + _gfortran_ieee_next_after_10_8, & + _gfortran_ieee_next_after_10_4, & +#endif +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_next_after_8_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_next_after_8_10, & +#endif + _gfortran_ieee_next_after_8_8, & + _gfortran_ieee_next_after_8_4, & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_next_after_4_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_next_after_4_10, & +#endif + _gfortran_ieee_next_after_4_8, & + _gfortran_ieee_next_after_4_4 end interface public :: IEEE_NEXT_AFTER ! IEEE_REM +#define REM_MACRO(RES,A,B) \ + elemental real(kind = RES) function \ + _gfortran_ieee_rem_/**/A/**/_/**/B (X,Y) ; \ + real(kind = A), intent(in) :: X ; \ + real(kind = B), intent(in) :: Y ; \ + end function + interface - elemental real(kind=4) function _gfortran_ieee_rem_4_4 (X, Y) - real(kind=4), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_rem_4_8 (X, Y) - real(kind=4), intent(in) :: X - real(kind=8), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_rem_8_4 (X, Y) - real(kind=8), intent(in) :: X - real(kind=4), intent(in) :: Y - end function - elemental real(kind=8) function _gfortran_ieee_rem_8_8 (X, Y) - real(kind=8), intent(in) :: X - real(kind=8), intent(in) :: Y - end function +REM_MACRO(4,4,4) +REM_MACRO(8,4,8) +#ifdef HAVE_GFC_REAL_10 +REM_MACRO(10,4,10) +#endif +#ifdef HAVE_GFC_REAL_16 +REM_MACRO(16,4,16) +#endif +REM_MACRO(8,8,4) +REM_MACRO(8,8,8) +#ifdef HAVE_GFC_REAL_10 +REM_MACRO(10,8,10) +#endif +#ifdef HAVE_GFC_REAL_16 +REM_MACRO(16,8,16) +#endif +#ifdef HAVE_GFC_REAL_10 +REM_MACRO(10,10,4) +REM_MACRO(10,10,8) +REM_MACRO(10,10,10) +#ifdef HAVE_GFC_REAL_16 +REM_MACRO(16,10,16) +#endif +#endif +#ifdef HAVE_GFC_REAL_16 +REM_MACRO(16,16,4) +REM_MACRO(16,16,8) +#ifdef HAVE_GFC_REAL_10 +REM_MACRO(16,16,10) +#endif +REM_MACRO(16,16,16) +#endif end interface interface IEEE_REM - procedure _gfortran_ieee_rem_4_4, _gfortran_ieee_rem_4_8, & - _gfortran_ieee_rem_8_4, _gfortran_ieee_rem_8_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_rem_16_16, & +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_rem_16_10, & +#endif + _gfortran_ieee_rem_16_8, & + _gfortran_ieee_rem_16_4, & +#endif +#ifdef HAVE_GFC_REAL_10 +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_rem_10_16, & +#endif + _gfortran_ieee_rem_10_10, & + _gfortran_ieee_rem_10_8, & + _gfortran_ieee_rem_10_4, & +#endif +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_rem_8_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_rem_8_10, & +#endif + _gfortran_ieee_rem_8_8, & + _gfortran_ieee_rem_8_4, & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_rem_4_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_rem_4_10, & +#endif + _gfortran_ieee_rem_4_8, & + _gfortran_ieee_rem_4_4 end interface public :: IEEE_REM @@ -283,10 +585,27 @@ module IEEE_ARITHMETIC elemental real(kind=8) function _gfortran_ieee_rint_8 (X) real(kind=8), intent(in) :: X end function +#ifdef HAVE_GFC_REAL_10 + elemental real(kind=10) function _gfortran_ieee_rint_10 (X) + real(kind=10), intent(in) :: X + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental real(kind=16) function _gfortran_ieee_rint_16 (X) + real(kind=16), intent(in) :: X + end function +#endif end interface interface IEEE_RINT - procedure _gfortran_ieee_rint_4, _gfortran_ieee_rint_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_rint_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_rint_10, & +#endif + _gfortran_ieee_rint_8, _gfortran_ieee_rint_4 end interface public :: IEEE_RINT @@ -301,24 +620,57 @@ module IEEE_ARITHMETIC real(kind=8), intent(in) :: X integer, intent(in) :: I end function +#ifdef HAVE_GFC_REAL_10 + elemental real(kind=10) function _gfortran_ieee_scalb_10 (X, I) + real(kind=10), intent(in) :: X + integer, intent(in) :: I + end function +#endif +#ifdef HAVE_GFC_REAL_16 + elemental real(kind=16) function _gfortran_ieee_scalb_16 (X, I) + real(kind=16), intent(in) :: X + integer, intent(in) :: I + end function +#endif end interface interface IEEE_SCALB - procedure _gfortran_ieee_scalb_4, _gfortran_ieee_scalb_8 + procedure & +#ifdef HAVE_GFC_REAL_16 + _gfortran_ieee_scalb_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + _gfortran_ieee_scalb_10, & +#endif + _gfortran_ieee_scalb_8, _gfortran_ieee_scalb_4 end interface public :: IEEE_SCALB ! IEEE_VALUE interface IEEE_VALUE - module procedure IEEE_VALUE_4, IEEE_VALUE_8 + module procedure & +#ifdef HAVE_GFC_REAL_16 + IEEE_VALUE_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + IEEE_VALUE_10, & +#endif + IEEE_VALUE_8, IEEE_VALUE_4 end interface public :: IEEE_VALUE ! IEEE_CLASS interface IEEE_CLASS - module procedure IEEE_CLASS_4, IEEE_CLASS_8 + module procedure & +#ifdef HAVE_GFC_REAL_16 + IEEE_CLASS_16, & +#endif +#ifdef HAVE_GFC_REAL_10 + IEEE_CLASS_10, & +#endif + IEEE_CLASS_8, IEEE_CLASS_4 end interface public :: IEEE_CLASS @@ -424,47 +776,19 @@ contains res = (X%hidden /= Y%hidden) end function + ! IEEE_SELECTED_REAL_KIND + integer function IEEE_SELECTED_REAL_KIND (P, R, RADIX) result(res) implicit none integer, intent(in), optional :: P, R, RADIX - integer :: p2, r2 - - p2 = 0 ; r2 = 0 - if (present(p)) p2 = p - if (present(r)) r2 = r - - ! The only IEEE types we support right now are binary - if (present(radix)) then - if (radix /= 2) then - res = -5 - return - endif - endif - - ! Does IEEE float fit? - if (precision(0.) >= p2 .and. range(0.) >= r2) then - res = kind(0.) - return - endif - - ! Does IEEE double fit? - if (precision(0.d0) >= p2 .and. range(0.d0) >= r2) then - res = kind(0.d0) - return - endif - - if (precision(0.d0) < p2 .and. range(0.d0) < r2) then - res = -3 - return - endif - - if (precision(0.d0) < p2) then - res = -1 - return - endif - - res = -2 + + ! Currently, if IEEE is supported and this module is built, it means + ! all our floating-point types conform to IEEE. Hence, we simply call + ! SELECTED_REAL_KIND. + + res = SELECTED_REAL_KIND (P, R, RADIX) + end function @@ -498,6 +822,39 @@ contains res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_8(X)) end function +#ifdef HAVE_GFC_REAL_10 + elemental function IEEE_CLASS_10 (X) result(res) + implicit none + real(kind=10), intent(in) :: X + type(IEEE_CLASS_TYPE) :: res + + interface + pure integer function _gfortrani_ieee_class_helper_10(val) + real(kind=10), intent(in) :: val + end function + end interface + + res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_10(X)) + end function +#endif + +#ifdef HAVE_GFC_REAL_16 + elemental function IEEE_CLASS_16 (X) result(res) + implicit none + real(kind=16), intent(in) :: X + type(IEEE_CLASS_TYPE) :: res + + interface + pure integer function _gfortrani_ieee_class_helper_16(val) + real(kind=16), intent(in) :: val + end function + end interface + + res = IEEE_CLASS_TYPE(_gfortrani_ieee_class_helper_16(X)) + end function +#endif + + ! IEEE_VALUE elemental real(kind=4) function IEEE_VALUE_4(X, C) result(res) @@ -576,6 +933,86 @@ contains end select end function +#ifdef HAVE_GFC_REAL_10 + elemental real(kind=10) function IEEE_VALUE_10(X, C) result(res) + implicit none + real(kind=10), intent(in) :: X + type(IEEE_CLASS_TYPE), intent(in) :: C + + select case (C%hidden) + case (1) ! IEEE_SIGNALING_NAN + res = -1 + res = sqrt(res) + case (2) ! IEEE_QUIET_NAN + res = -1 + res = sqrt(res) + case (3) ! IEEE_NEGATIVE_INF + res = huge(res) + res = (-res) * res + case (4) ! IEEE_NEGATIVE_NORMAL + res = -42 + case (5) ! IEEE_NEGATIVE_DENORMAL + res = -tiny(res) + res = res / 2 + case (6) ! IEEE_NEGATIVE_ZERO + res = 0 + res = -res + case (7) ! IEEE_POSITIVE_ZERO + res = 0 + case (8) ! IEEE_POSITIVE_DENORMAL + res = tiny(res) + res = res / 2 + case (9) ! IEEE_POSITIVE_NORMAL + res = 42 + case (10) ! IEEE_POSITIVE_INF + res = huge(res) + res = res * res + case default ! IEEE_OTHER_VALUE, should not happen + res = 0 + end select + end function +#endif + +#ifdef HAVE_GFC_REAL_16 + elemental real(kind=16) function IEEE_VALUE_16(X, C) result(res) + implicit none + real(kind=16), intent(in) :: X + type(IEEE_CLASS_TYPE), intent(in) :: C + + select case (C%hidden) + case (1) ! IEEE_SIGNALING_NAN + res = -1 + res = sqrt(res) + case (2) ! IEEE_QUIET_NAN + res = -1 + res = sqrt(res) + case (3) ! IEEE_NEGATIVE_INF + res = huge(res) + res = (-res) * res + case (4) ! IEEE_NEGATIVE_NORMAL + res = -42 + case (5) ! IEEE_NEGATIVE_DENORMAL + res = -tiny(res) + res = res / 2 + case (6) ! IEEE_NEGATIVE_ZERO + res = 0 + res = -res + case (7) ! IEEE_POSITIVE_ZERO + res = 0 + case (8) ! IEEE_POSITIVE_DENORMAL + res = tiny(res) + res = res / 2 + case (9) ! IEEE_POSITIVE_NORMAL + res = 42 + case (10) ! IEEE_POSITIVE_INF + res = huge(res) + res = res * res + case default ! IEEE_OTHER_VALUE, should not happen + res = 0 + end select + end function +#endif + ! IEEE_GET_ROUNDING_MODE @@ -663,7 +1100,7 @@ contains implicit none real(kind=10), intent(in) :: X type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE - res = .false. + res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) end function #endif @@ -672,18 +1109,14 @@ contains implicit none real(kind=16), intent(in) :: X type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE - res = .false. + res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) end function #endif pure logical function IEEE_SUPPORT_ROUNDING_NOARG (ROUND_VALUE) result(res) implicit none type(IEEE_ROUND_TYPE), intent(in) :: ROUND_VALUE -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) - res = .false. -#else res = (support_rounding_helper(ROUND_VALUE%hidden) /= 0) -#endif end function ! IEEE_SUPPORT_UNDERFLOW_CONTROL @@ -704,7 +1137,7 @@ contains pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_10 (X) result(res) implicit none real(kind=10), intent(in) :: X - res = .false. + res = (support_underflow_control_helper(10) /= 0) end function #endif @@ -712,18 +1145,21 @@ contains pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_16 (X) result(res) implicit none real(kind=16), intent(in) :: X - res = .false. + res = (support_underflow_control_helper(16) /= 0) end function #endif pure logical function IEEE_SUPPORT_UNDERFLOW_CONTROL_NOARG () result(res) implicit none -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) - res = .false. -#else res = (support_underflow_control_helper(4) /= 0 & - .and. support_underflow_control_helper(8) /= 0) + .and. support_underflow_control_helper(8) /= 0 & +#ifdef HAVE_GFC_REAL_10 + .and. support_underflow_control_helper(10) /= 0 & +#endif +#ifdef HAVE_GFC_REAL_16 + .and. support_underflow_control_helper(16) /= 0 & #endif + ) end function ! IEEE_SUPPORT_* functions @@ -746,127 +1182,95 @@ contains SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DATATYPE,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_DATATYPE,.true.) -#endif ! IEEE_SUPPORT_DENORMAL SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DENORMAL,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_DENORMAL,.true.) -#endif ! IEEE_SUPPORT_DIVIDE SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_DIVIDE,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_DIVIDE,.true.) -#endif ! IEEE_SUPPORT_INF SUPPORTMACRO(IEEE_SUPPORT_INF,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_INF,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_INF,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_INF,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_INF,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_INF,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_INF,.true.) -#endif ! IEEE_SUPPORT_IO SUPPORTMACRO(IEEE_SUPPORT_IO,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_IO,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_IO,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_IO,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_IO,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_IO,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_IO,.true.) -#endif ! IEEE_SUPPORT_NAN SUPPORTMACRO(IEEE_SUPPORT_NAN,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_NAN,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_NAN,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_NAN,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_NAN,.true.) -#endif ! IEEE_SUPPORT_SQRT SUPPORTMACRO(IEEE_SUPPORT_SQRT,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_SQRT,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_SQRT,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_SQRT,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_SQRT,.true.) -#endif ! IEEE_SUPPORT_STANDARD SUPPORTMACRO(IEEE_SUPPORT_STANDARD,4,.true.) SUPPORTMACRO(IEEE_SUPPORT_STANDARD,8,.true.) #ifdef HAVE_GFC_REAL_10 -SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.false.) +SUPPORTMACRO(IEEE_SUPPORT_STANDARD,10,.true.) #endif #ifdef HAVE_GFC_REAL_16 -SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.false.) +SUPPORTMACRO(IEEE_SUPPORT_STANDARD,16,.true.) #endif -#if defined(HAVE_GFC_REAL_10) || defined(HAVE_GFC_REAL_16) -SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.false.) -#else SUPPORTMACRO_NOARG(IEEE_SUPPORT_STANDARD,.true.) -#endif end module IEEE_ARITHMETIC diff --git a/libgfortran/ieee/ieee_exceptions.F90 b/libgfortran/ieee/ieee_exceptions.F90 index 4283906eb26..662c42f03e0 100644 --- a/libgfortran/ieee/ieee_exceptions.F90 +++ b/libgfortran/ieee/ieee_exceptions.F90 @@ -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 diff --git a/libgfortran/ieee/ieee_helper.c b/libgfortran/ieee/ieee_helper.c index c8ed77b15f3..f3362d42ef3 100644 --- a/libgfortran/ieee/ieee_helper.c +++ b/libgfortran/ieee/ieee_helper.c @@ -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 | \ -- 2.30.2