From 18a38dd7618094e6688101bf69dd563dd8805e11 Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Thu, 6 Aug 2015 09:22:30 +0000 Subject: [PATCH] PR fortran/64022 * gfortran.dg/ieee/large_2.f90: New test. * gfortran.dg/ieee/large_3.F90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@226670 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/ieee/large_2.f90 | 145 ++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/ieee/large_3.F90 | 157 +++++++++++++++++++++++++++++ 3 files changed, 308 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/ieee/large_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/large_3.F90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1d7e6a6edfc..dad3c512bb2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,6 +1,12 @@ 2015-08-06 Francois-Xavier Coudert PR fortran/64022 + * gfortran.dg/ieee/large_2.f90: New test. + * gfortran.dg/ieee/large_3.F90: New test. + +2015-08-06 Francois-Xavier Coudert + + PR fortran/64022 * gfortran.dg/ieee/large_1.f90: Adjust test. 2015-08-05 Manuel López-Ibáñez diff --git a/gcc/testsuite/gfortran.dg/ieee/large_2.f90 b/gcc/testsuite/gfortran.dg/ieee/large_2.f90 new file mode 100644 index 00000000000..54e33971054 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/large_2.f90 @@ -0,0 +1,145 @@ +! { dg-do run } +! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } + + use, intrinsic :: ieee_features + use, intrinsic :: 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)) + + interface check_equal + procedure check_equal1, check_equal2 + end interface + + interface check_not_equal + procedure check_not_equal1, check_not_equal2 + end interface + + interface divide + procedure divide1, divide2 + end interface + + real(kind=k1) :: x1, x2, x3 + real(kind=k2) :: y1, y2, y3 + type(ieee_round_type) :: mode + + if (ieee_support_rounding(ieee_up, x1) .and. & + ieee_support_rounding(ieee_down, x1) .and. & + ieee_support_rounding(ieee_nearest, x1) .and. & + ieee_support_rounding(ieee_to_zero, x1)) then + + x1 = 1 + x2 = 3 + x1 = divide(x1, x2, ieee_up) + + x3 = 1 + x2 = 3 + x3 = divide(x3, x2, ieee_down) + call check_not_equal(x1, x3) + call check_equal(x3, nearest(x1, -1._k1)) + call check_equal(x1, nearest(x3, 1._k1)) + + call check_equal(1._k1/3._k1, divide(1._k1, 3._k1, ieee_nearest)) + call check_equal(-1._k1/3._k1, divide(-1._k1, 3._k1, ieee_nearest)) + + call check_equal(divide(3._k1, 7._k1, ieee_to_zero), & + divide(3._k1, 7._k1, ieee_down)) + call check_equal(divide(-3._k1, 7._k1, ieee_to_zero), & + divide(-3._k1, 7._k1, ieee_up)) + + end if + + if (ieee_support_rounding(ieee_up, y1) .and. & + ieee_support_rounding(ieee_down, y1) .and. & + ieee_support_rounding(ieee_nearest, y1) .and. & + ieee_support_rounding(ieee_to_zero, y1)) then + + y1 = 1 + y2 = 3 + y1 = divide(y1, y2, ieee_up) + + y3 = 1 + y2 = 3 + y3 = divide(y3, y2, ieee_down) + call check_not_equal(y1, y3) + call check_equal(y3, nearest(y1, -1._k2)) + call check_equal(y1, nearest(y3, 1._k2)) + + call check_equal(1._k2/3._k2, divide(1._k2, 3._k2, ieee_nearest)) + call check_equal(-1._k2/3._k2, divide(-1._k2, 3._k2, ieee_nearest)) + + call check_equal(divide(3._k2, 7._k2, ieee_to_zero), & + divide(3._k2, 7._k2, ieee_down)) + call check_equal(divide(-3._k2, 7._k2, ieee_to_zero), & + divide(-3._k2, 7._k2, ieee_up)) + + end if + +contains + + real(kind=k1) function divide1 (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real(kind=k1), intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + real(kind=k2) function divide2 (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real(kind=k2), intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + subroutine check_equal1 (x, y) + real(kind=k1), intent(in) :: x, y + if (x /= y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_equal2 (x, y) + real(kind=k2), intent(in) :: x, y + if (x /= y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_not_equal1 (x, y) + real(kind=k1), intent(in) :: x, y + if (x == y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_not_equal2 (x, y) + real(kind=k2), intent(in) :: x, y + if (x == y) then + print *, x, y + call abort + end if + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/ieee/large_3.F90 b/gcc/testsuite/gfortran.dg/ieee/large_3.F90 new file mode 100644 index 00000000000..fbba091d031 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/large_3.F90 @@ -0,0 +1,157 @@ +! { dg-do run } +! { dg-additional-options "-ffree-line-length-none" } +! { dg-additional-options "-mfp-trap-mode=sui" { target alpha*-*-* } } +! +! Use dg-additional-options rather than dg-options to avoid overwriting the +! default IEEE options which are passed by ieee.exp and necessary. + + use ieee_features + use ieee_exceptions + 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)) + + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + logical :: l(5) = .false. + character(len=5) :: s + +#define FLAGS_STRING(S) \ + call ieee_get_flag(x, l) ; \ + write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l) + +#define CHECK_FLAGS(expected) \ + FLAGS_STRING(s) ; \ + if (s /= expected) then ; \ + write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \ + call abort ; \ + end if ; \ + call check_flag_sub + + real(kind=k1), volatile :: sx + real(kind=k2), volatile :: dx + + ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG + + !!!! Large kind 1 + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + sx = -1 + sx = sqrt(sx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + sx = huge(sx) + CHECK_FLAGS(" ") + sx = sx*sx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + sx = 0 + sx = 1 / sx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + sx = tiny(sx) + CHECK_FLAGS(" ") + sx = sx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + + !!!! Large kind 2 + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + dx = -1 + dx = sqrt(dx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + dx = huge(dx) + CHECK_FLAGS(" ") + dx = dx*dx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + dx = 0 + dx = 1 / dx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + dx = tiny(dx) + CHECK_FLAGS(" ") + dx = dx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + +contains + + subroutine check_flag_sub + use ieee_exceptions + logical :: l(5) = .false. + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + call ieee_get_flag(x, l) + + if (any(l)) then + print *, "Flags not cleared in subroutine" + call abort + end if + end subroutine + +end -- 2.11.4.GIT