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

   1 ! { dg-do run }
   2 ! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } }
   3
   4   use, intrinsic :: ieee_features, only : ieee_rounding
   5   use, intrinsic :: ieee_arithmetic
   6   implicit none
   7
   8   interface check_equal
   9     procedure check_equal_float, check_equal_double
  10   end interface
  11
  12   interface check_not_equal
  13     procedure check_not_equal_float, check_not_equal_double
  14   end interface
  15
  16   interface divide
  17     procedure divide_float, divide_double
  18   end interface
  19
  20   real :: sx1, sx2, sx3
  21   double precision :: dx1, dx2, dx3
  22   type(ieee_round_type) :: mode
  23
  24   ! We should support at least C float and C double types
  25   if (ieee_support_rounding(ieee_nearest)) then
  26     if (.not. ieee_support_rounding(ieee_nearest, 0.)) call abort
  27     if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) call abort
  28   end if
  29
  30   ! The initial rounding mode should probably be NEAREST
  31   ! (at least on the platforms we currently support)
  32   if (ieee_support_rounding(ieee_nearest, 0.)) then
  33     call ieee_get_rounding_mode (mode)
  34     if (mode /= ieee_nearest) call abort
  35   end if
  36
  37
  38   if (ieee_support_rounding(ieee_up, sx1) .and. &
  39       ieee_support_rounding(ieee_down, sx1) .and. &
  40       ieee_support_rounding(ieee_nearest, sx1) .and. &
  41       ieee_support_rounding(ieee_to_zero, sx1)) then
  42
  43     sx1 = 1
  44     sx2 = 3
  45     sx1 = divide(sx1, sx2, ieee_up)
  46
  47     sx3 = 1
  48     sx2 = 3
  49     sx3 = divide(sx3, sx2, ieee_down)
  50     call check_not_equal(sx1, sx3)
  51     call check_equal(sx3, nearest(sx1, -1.))
  52     call check_equal(sx1, nearest(sx3,  1.))
  53
  54     call check_equal(1./3., divide(1., 3., ieee_nearest))
  55     call check_equal(-1./3., divide(-1., 3., ieee_nearest))
  56
  57     call check_equal(divide(3., 7., ieee_to_zero), &
  58                     divide(3., 7., ieee_down))
  59     call check_equal(divide(-3., 7., ieee_to_zero), &
  60                     divide(-3., 7., ieee_up))
  61
  62   end if
  63
  64   if (ieee_support_rounding(ieee_up, dx1) .and. &
  65       ieee_support_rounding(ieee_down, dx1) .and. &
  66       ieee_support_rounding(ieee_nearest, dx1) .and. &
  67       ieee_support_rounding(ieee_to_zero, dx1)) then
  68
  69     dx1 = 1
  70     dx2 = 3
  71     dx1 = divide(dx1, dx2, ieee_up)
  72
  73     dx3 = 1
  74     dx2 = 3
  75     dx3 = divide(dx3, dx2, ieee_down)
  76     call check_not_equal(dx1, dx3)
  77     call check_equal(dx3, nearest(dx1, -1.d0))
  78     call check_equal(dx1, nearest(dx3,  1.d0))
  79
  80     call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest))
  81     call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest))
  82
  83     call check_equal(divide(3.d0, 7.d0, ieee_to_zero), &
  84                     divide(3.d0, 7.d0, ieee_down))
  85     call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), &
  86                     divide(-3.d0, 7.d0, ieee_up))
  87
  88   end if
  89
  90 contains
  91
  92   real function divide_float (x, y, rounding) result(res)
  93     use, intrinsic :: ieee_arithmetic
  94     real, intent(in) :: x, y
  95     type(ieee_round_type), intent(in) :: rounding
  96     type(ieee_round_type) :: old
  97
  98     call ieee_get_rounding_mode (old)
  99     call ieee_set_rounding_mode (rounding)
 100
 101     res = x / y
 102
 103     call ieee_set_rounding_mode (old)
 104   end function
 105
 106   double precision function divide_double (x, y, rounding) result(res)
 107     use, intrinsic :: ieee_arithmetic
 108     double precision, intent(in) :: x, y
 109     type(ieee_round_type), intent(in) :: rounding
 110     type(ieee_round_type) :: old
 111
 112     call ieee_get_rounding_mode (old)
 113     call ieee_set_rounding_mode (rounding)
 114
 115     res = x / y
 116
 117     call ieee_set_rounding_mode (old)
 118   end function
 119
 120   subroutine check_equal_float (x, y)
 121     real, intent(in) :: x, y
 122     if (x /= y) then
 123       print *, x, y
 124       call abort
 125     end if
 126   end subroutine
 127
 128   subroutine check_equal_double (x, y)
 129     double precision, intent(in) :: x, y
 130     if (x /= y) then
 131       print *, x, y
 132       call abort
 133     end if
 134   end subroutine
 135
 136   subroutine check_not_equal_float (x, y)
 137     real, intent(in) :: x, y
 138     if (x == y) then
 139       print *, x, y
 140       call abort
 141     end if
 142   end subroutine
 143
 144   subroutine check_not_equal_double (x, y)
 145     double precision, intent(in) :: x, y
 146     if (x == y) then
 147       print *, x, y
 148       call abort
 149     end if
 150   end subroutine
 151
 152 end