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
	* gfortran.dg/ieee/large_2.f90: New test.
	* gfortran.dg/ieee/large_3.F90: New test.

From-SVN: r226670

gcc/testsuite/ChangeLog

 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
 	* gfortran.dg/ieee/large_1.f90: Adjust test.
 
 2015-08-05  Manuel López-Ibáñez  <manu@gcc.gnu.org>

gcc/testsuite/gfortran.dg/ieee/large_2.f90

+! { 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

gcc/testsuite/gfortran.dg/ieee/large_3.F90

+! { 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