Skip to content

R
riscv-gcc-1
Commit 22a49988 by Francois-Xavier Coudert Committed by François-Xavier Coudert
Options

re PR fortran/64022 ([F2003][IEEE] ieee_support_flag does not handle kind=10 and… 

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
parent 0ad23163
Showing with 811 additions and 257 deletions
gcc/fortran/ChangeLog
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
......
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);
}
......
gcc/testsuite/ChangeLog
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
......
gcc/testsuite/gfortran.dg/ieee/ieee_7.f90
! { 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
gcc/testsuite/gfortran.dg/ieee/large_1.f90 0 → 100644
! { 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
libgfortran/ChangeLog
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
......
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;
......
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
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
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 | \
......
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