--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff