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

   1 ! { dg-do run }
   2 !
   3 ! Test IEEE_MODES_TYPE, IEEE_GET_MODES and IEEE_SET_MODES
   4
   5
   6 ! The symbols should be accessible from both IEEE_EXCEPTIONS
   7 ! and IEEE_ARITHMETIC.
   8
   9 subroutine test_1
  10   use ieee_exceptions, only : IEEE_GET_MODES, IEEE_SET_MODES
  11 end subroutine
  12
  13 subroutine test_2
  14   use ieee_arithmetic, only : IEEE_GET_MODES, IEEE_SET_MODES
  15 end subroutine
  16
  17 subroutine test_3
  18   use ieee_exceptions, only : IEEE_MODES_TYPE
  19 end subroutine
  20
  21 subroutine test_4
  22   use ieee_arithmetic, only : IEEE_MODES_TYPE
  23 end subroutine
  24
  25
  26 ! Check that the functions actually do the job
  27
  28 program foo
  29   use ieee_arithmetic
  30   implicit none
  31
  32   type(ieee_modes_type) :: modes1, modes2
  33   type(ieee_round_type) :: rmode
  34   logical :: f
  35
  36   ! Set some modes
  37   if (ieee_support_underflow_control()) then
  38     call ieee_set_underflow_mode(gradual=.false.)
  39   endif
  40   if (ieee_support_rounding(ieee_up)) then
  41     call ieee_set_rounding_mode(ieee_up)
  42   endif
  43   if (ieee_support_halting(ieee_overflow)) then
  44     call ieee_set_halting_mode(ieee_overflow, .true.)
  45   endif
  46
  47   call ieee_get_modes(modes1)
  48
  49   ! Change modes
  50   if (ieee_support_underflow_control()) then
  51     call ieee_set_underflow_mode(gradual=.true.)
  52   endif
  53   if (ieee_support_rounding(ieee_down)) then
  54     call ieee_set_rounding_mode(ieee_down)
  55   endif
  56   if (ieee_support_halting(ieee_overflow)) then
  57     call ieee_set_halting_mode(ieee_overflow, .false.)
  58   endif
  59
  60   ! Save and restore the previous modes
  61   call ieee_get_modes(modes2)
  62   call ieee_set_modes(modes1)
  63
  64   ! Check them
  65   if (ieee_support_underflow_control()) then
  66     call ieee_get_underflow_mode(f)
  67     if (f) stop 1
  68   endif
  69   if (ieee_support_rounding(ieee_down)) then
  70     call ieee_get_rounding_mode(rmode)
  71     if (rmode /= ieee_up) stop 2
  72   endif
  73   if (ieee_support_halting(ieee_overflow)) then
  74     call ieee_get_halting_mode(ieee_overflow, f)
  75     if (.not. f) stop 3
  76   endif
  77
  78   ! Restore the second set of modes
  79   call ieee_set_modes(modes2)
  80
  81   ! Check again
  82   if (ieee_support_underflow_control()) then
  83     call ieee_get_underflow_mode(f)
  84     if (.not. f) stop 3
  85   endif
  86   if (ieee_support_rounding(ieee_down)) then
  87     call ieee_get_rounding_mode(rmode)
  88     if (rmode /= ieee_down) stop 4
  89   endif
  90   if (ieee_support_halting(ieee_overflow)) then
  91     call ieee_get_halting_mode(ieee_overflow, f)
  92     if (f) stop 5
  93   endif
  94
  95 end program foo