mirror of git://gcc.gnu.org/git/gcc.git
re PR fortran/64022 ([F2003][IEEE] ieee_support_flag does not handle kind=10 and kind=16 REAL variables)
PR fortran/64022 * gfortran.dg/ieee/large_2.f90: New test. * gfortran.dg/ieee/large_3.F90: New test. From-SVN: r226670
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
a3fe41f5c9
commit
cfe25557ad
|
|
@ -1,3 +1,9 @@
|
|||
2015-08-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
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 <fxcoudert@gcc.gnu.org>
|
||||
|
||||
PR fortran/64022
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue