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

   1 ! { dg-do run }
   2 ! { dg-additional-options "-ffree-line-length-none" }
   3 !
   4 ! Use dg-additional-options rather than dg-options to avoid overwriting the
   5 ! default IEEE options which are passed by ieee.exp and necessary.
   6
   7   use ieee_features, only : ieee_datatype, ieee_denormal, ieee_divide, &
   8       ieee_halting, ieee_inexact_flag, ieee_inf, ieee_invalid_flag, &
   9       ieee_nan, ieee_rounding, ieee_sqrt, ieee_underflow_flag
  10   use ieee_exceptions
  11
  12   implicit none
  13
  14   type(ieee_flag_type), parameter :: x(5) = &
  15     [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
  16       IEEE_UNDERFLOW, IEEE_INEXACT ]
  17   logical :: l(5) = .false.
  18   character(len=5) :: s
  19
  20 #define FLAGS_STRING(S) \
  21   call ieee_get_flag(x, l) ; \
  22   write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l)
  23
  24 #define CHECK_FLAGS(expected) \
  25   FLAGS_STRING(s) ; \
  26   if (s /= expected) then ; \
  27     write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \
  28     call abort ; \
  29   end if ; \
  30   call check_flag_sub
  31
  32   real, volatile :: sx
  33   double precision, volatile :: dx
  34
  35   ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG
  36
  37   !!!! IEEE float
  38
  39   ! Initial flags are all off
  40   CHECK_FLAGS("     ")
  41
  42   ! Check we can clear them
  43   call ieee_set_flag(ieee_all, .false.)
  44   CHECK_FLAGS("     ")
  45
  46   ! Raise invalid, then clear
  47   sx = -1
  48   sx = sqrt(sx)
  49   CHECK_FLAGS("I    ")
  50   call ieee_set_flag(ieee_all, .false.)
  51   CHECK_FLAGS("     ")
  52
  53   ! Raise overflow and precision
  54   sx = huge(sx)
  55   CHECK_FLAGS("     ")
  56   sx = sx*sx
  57   CHECK_FLAGS(" O  P")
  58
  59   ! Also raise divide-by-zero
  60   sx = 0
  61   sx = 1 / sx
  62   CHECK_FLAGS(" OZ P")
  63
  64   ! Clear them
  65   call ieee_set_flag([ieee_overflow,ieee_inexact,&
  66                       ieee_divide_by_zero],[.false.,.false.,.true.])
  67   CHECK_FLAGS("  Z  ")
  68   call ieee_set_flag(ieee_divide_by_zero, .false.)
  69   CHECK_FLAGS("     ")
  70
  71   ! Raise underflow
  72   sx = tiny(sx)
  73   CHECK_FLAGS("     ")
  74   sx = sx / 10
  75   CHECK_FLAGS("   UP")
  76
  77   ! Raise everything
  78   call ieee_set_flag(ieee_all, .true.)
  79   CHECK_FLAGS("IOZUP")
  80
  81   ! And clear
  82   call ieee_set_flag(ieee_all, .false.)
  83   CHECK_FLAGS("     ")
  84
  85   !!!! IEEE double
  86
  87   ! Initial flags are all off
  88   CHECK_FLAGS("     ")
  89
  90   ! Check we can clear them
  91   call ieee_set_flag(ieee_all, .false.)
  92   CHECK_FLAGS("     ")
  93
  94   ! Raise invalid, then clear
  95   dx = -1
  96   dx = sqrt(dx)
  97   CHECK_FLAGS("I    ")
  98   call ieee_set_flag(ieee_all, .false.)
  99   CHECK_FLAGS("     ")
 100
 101   ! Raise overflow and precision
 102   dx = huge(dx)
 103   CHECK_FLAGS("     ")
 104   dx = dx*dx
 105   CHECK_FLAGS(" O  P")
 106
 107   ! Also raise divide-by-zero
 108   dx = 0
 109   dx = 1 / dx
 110   CHECK_FLAGS(" OZ P")
 111
 112   ! Clear them
 113   call ieee_set_flag([ieee_overflow,ieee_inexact,&
 114                       ieee_divide_by_zero],[.false.,.false.,.true.])
 115   CHECK_FLAGS("  Z  ")
 116   call ieee_set_flag(ieee_divide_by_zero, .false.)
 117   CHECK_FLAGS("     ")
 118
 119   ! Raise underflow
 120   dx = tiny(dx)
 121   CHECK_FLAGS("     ")
 122   dx = dx / 10
 123   CHECK_FLAGS("   UP")
 124
 125   ! Raise everything
 126   call ieee_set_flag(ieee_all, .true.)
 127   CHECK_FLAGS("IOZUP")
 128
 129   ! And clear
 130   call ieee_set_flag(ieee_all, .false.)
 131   CHECK_FLAGS("     ")
 132
 133 contains
 134
 135   subroutine check_flag_sub
 136     use ieee_exceptions
 137     logical :: l(5) = .false.
 138     type(ieee_flag_type), parameter :: x(5) = &
 139       [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
 140         IEEE_UNDERFLOW, IEEE_INEXACT ]
 141     call ieee_get_flag(x, l)
 142
 143     if (any(l)) then
 144       print *, "Flags not cleared in subroutine"
 145       call abort
 146     end if
 147   end subroutine
 148
 149 end