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