From befdff260962b8a963b751df3a872a38e10a7567 Mon Sep 17 00:00:00 2001 From: Uros Bizjak Date: Tue, 15 Jul 2014 18:12:38 +0200 Subject: rounding_1.f90: Rename from ieee_rounding_1.f90. * gfortran.dg/ieee/rounding_1.f90: Rename from ieee_rounding_1.f90. * gfortran.dg/ieee/ieee_1.f90: Rename from ieee_1.F90. (dg-additional-options): Add -mieee-with-inexact for alpha*-*-*. From-SVN: r212570 --- gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 | 149 -------------------- gcc/testsuite/gfortran.dg/ieee/ieee_1.f90 | 150 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 | 152 --------------------- gcc/testsuite/gfortran.dg/ieee/rounding_1.f90 | 152 +++++++++++++++++++++ 4 files changed, 302 insertions(+), 301 deletions(-) delete mode 100644 gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/ieee_1.f90 delete mode 100644 gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/rounding_1.f90 (limited to 'gcc') diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 b/gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 deleted file mode 100644 index 329aeef..0000000 --- a/gcc/testsuite/gfortran.dg/ieee/ieee_1.F90 +++ /dev/null @@ -1,149 +0,0 @@ -! { dg-do run } -! { dg-additional-options "-ffree-line-length-none" } -! -! 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, only : ieee_datatype, ieee_denormal, ieee_divide, & - ieee_halting, ieee_inexact_flag, ieee_inf, ieee_invalid_flag, & - ieee_nan, ieee_rounding, ieee_sqrt, ieee_underflow_flag - use ieee_exceptions - - implicit none - - 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, volatile :: sx - double precision, volatile :: dx - - ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG - - !!!! IEEE float - - ! 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(" ") - - !!!! IEEE double - - ! 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 diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_1.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_1.f90 new file mode 100644 index 0000000..8e2e0ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/ieee_1.f90 @@ -0,0 +1,150 @@ +! { dg-do run } +! { dg-additional-options "-ffree-line-length-none" } +! { dg-additional-options "-mieee-with-inexact" { 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, only : ieee_datatype, ieee_denormal, ieee_divide, & + ieee_halting, ieee_inexact_flag, ieee_inf, ieee_invalid_flag, & + ieee_nan, ieee_rounding, ieee_sqrt, ieee_underflow_flag + use ieee_exceptions + + implicit none + + 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, volatile :: sx + double precision, volatile :: dx + + ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG + + !!!! IEEE float + + ! 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(" ") + + !!!! IEEE double + + ! 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 diff --git a/gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 b/gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 deleted file mode 100644 index c44178e..0000000 --- a/gcc/testsuite/gfortran.dg/ieee/ieee_rounding_1.f90 +++ /dev/null @@ -1,152 +0,0 @@ -! { dg-do run } -! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } - - use, intrinsic :: ieee_features, only : ieee_rounding - use, intrinsic :: ieee_arithmetic - implicit none - - interface check_equal - procedure check_equal_float, check_equal_double - end interface - - interface check_not_equal - procedure check_not_equal_float, check_not_equal_double - end interface - - interface divide - procedure divide_float, divide_double - end interface - - real :: sx1, sx2, sx3 - double precision :: dx1, dx2, dx3 - type(ieee_round_type) :: mode - - ! We should support at least C float and C double types - if (ieee_support_rounding(ieee_nearest)) then - if (.not. ieee_support_rounding(ieee_nearest, 0.)) call abort - if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) call abort - end if - - ! The initial rounding mode should probably be NEAREST - ! (at least on the platforms we currently support) - if (ieee_support_rounding(ieee_nearest, 0.)) then - call ieee_get_rounding_mode (mode) - if (mode /= ieee_nearest) call abort - end if - - - if (ieee_support_rounding(ieee_up, sx1) .and. & - ieee_support_rounding(ieee_down, sx1) .and. & - ieee_support_rounding(ieee_nearest, sx1) .and. & - ieee_support_rounding(ieee_to_zero, sx1)) then - - sx1 = 1 - sx2 = 3 - sx1 = divide(sx1, sx2, ieee_up) - - sx3 = 1 - sx2 = 3 - sx3 = divide(sx3, sx2, ieee_down) - call check_not_equal(sx1, sx3) - call check_equal(sx3, nearest(sx1, -1.)) - call check_equal(sx1, nearest(sx3, 1.)) - - call check_equal(1./3., divide(1., 3., ieee_nearest)) - call check_equal(-1./3., divide(-1., 3., ieee_nearest)) - - call check_equal(divide(3., 7., ieee_to_zero), & - divide(3., 7., ieee_down)) - call check_equal(divide(-3., 7., ieee_to_zero), & - divide(-3., 7., ieee_up)) - - end if - - if (ieee_support_rounding(ieee_up, dx1) .and. & - ieee_support_rounding(ieee_down, dx1) .and. & - ieee_support_rounding(ieee_nearest, dx1) .and. & - ieee_support_rounding(ieee_to_zero, dx1)) then - - dx1 = 1 - dx2 = 3 - dx1 = divide(dx1, dx2, ieee_up) - - dx3 = 1 - dx2 = 3 - dx3 = divide(dx3, dx2, ieee_down) - call check_not_equal(dx1, dx3) - call check_equal(dx3, nearest(dx1, -1.d0)) - call check_equal(dx1, nearest(dx3, 1.d0)) - - call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest)) - call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest)) - - call check_equal(divide(3.d0, 7.d0, ieee_to_zero), & - divide(3.d0, 7.d0, ieee_down)) - call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), & - divide(-3.d0, 7.d0, ieee_up)) - - end if - -contains - - real function divide_float (x, y, rounding) result(res) - use, intrinsic :: ieee_arithmetic - real, 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 - - double precision function divide_double (x, y, rounding) result(res) - use, intrinsic :: ieee_arithmetic - double precision, 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_equal_float (x, y) - real, intent(in) :: x, y - if (x /= y) then - print *, x, y - call abort - end if - end subroutine - - subroutine check_equal_double (x, y) - double precision, intent(in) :: x, y - if (x /= y) then - print *, x, y - call abort - end if - end subroutine - - subroutine check_not_equal_float (x, y) - real, intent(in) :: x, y - if (x == y) then - print *, x, y - call abort - end if - end subroutine - - subroutine check_not_equal_double (x, y) - double precision, 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/rounding_1.f90 b/gcc/testsuite/gfortran.dg/ieee/rounding_1.f90 new file mode 100644 index 0000000..c44178e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/rounding_1.f90 @@ -0,0 +1,152 @@ +! { dg-do run } +! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } + + use, intrinsic :: ieee_features, only : ieee_rounding + use, intrinsic :: ieee_arithmetic + implicit none + + interface check_equal + procedure check_equal_float, check_equal_double + end interface + + interface check_not_equal + procedure check_not_equal_float, check_not_equal_double + end interface + + interface divide + procedure divide_float, divide_double + end interface + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + type(ieee_round_type) :: mode + + ! We should support at least C float and C double types + if (ieee_support_rounding(ieee_nearest)) then + if (.not. ieee_support_rounding(ieee_nearest, 0.)) call abort + if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) call abort + end if + + ! The initial rounding mode should probably be NEAREST + ! (at least on the platforms we currently support) + if (ieee_support_rounding(ieee_nearest, 0.)) then + call ieee_get_rounding_mode (mode) + if (mode /= ieee_nearest) call abort + end if + + + if (ieee_support_rounding(ieee_up, sx1) .and. & + ieee_support_rounding(ieee_down, sx1) .and. & + ieee_support_rounding(ieee_nearest, sx1) .and. & + ieee_support_rounding(ieee_to_zero, sx1)) then + + sx1 = 1 + sx2 = 3 + sx1 = divide(sx1, sx2, ieee_up) + + sx3 = 1 + sx2 = 3 + sx3 = divide(sx3, sx2, ieee_down) + call check_not_equal(sx1, sx3) + call check_equal(sx3, nearest(sx1, -1.)) + call check_equal(sx1, nearest(sx3, 1.)) + + call check_equal(1./3., divide(1., 3., ieee_nearest)) + call check_equal(-1./3., divide(-1., 3., ieee_nearest)) + + call check_equal(divide(3., 7., ieee_to_zero), & + divide(3., 7., ieee_down)) + call check_equal(divide(-3., 7., ieee_to_zero), & + divide(-3., 7., ieee_up)) + + end if + + if (ieee_support_rounding(ieee_up, dx1) .and. & + ieee_support_rounding(ieee_down, dx1) .and. & + ieee_support_rounding(ieee_nearest, dx1) .and. & + ieee_support_rounding(ieee_to_zero, dx1)) then + + dx1 = 1 + dx2 = 3 + dx1 = divide(dx1, dx2, ieee_up) + + dx3 = 1 + dx2 = 3 + dx3 = divide(dx3, dx2, ieee_down) + call check_not_equal(dx1, dx3) + call check_equal(dx3, nearest(dx1, -1.d0)) + call check_equal(dx1, nearest(dx3, 1.d0)) + + call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest)) + call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest)) + + call check_equal(divide(3.d0, 7.d0, ieee_to_zero), & + divide(3.d0, 7.d0, ieee_down)) + call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), & + divide(-3.d0, 7.d0, ieee_up)) + + end if + +contains + + real function divide_float (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real, 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 + + double precision function divide_double (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + double precision, 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_equal_float (x, y) + real, intent(in) :: x, y + if (x /= y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_equal_double (x, y) + double precision, intent(in) :: x, y + if (x /= y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_not_equal_float (x, y) + real, intent(in) :: x, y + if (x == y) then + print *, x, y + call abort + end if + end subroutine + + subroutine check_not_equal_double (x, y) + double precision, intent(in) :: x, y + if (x == y) then + print *, x, y + call abort + end if + end subroutine + +end -- cgit v1.1