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   interface use_real
  15     procedure use_real_4, use_real_8
  16   end interface use_real
  17
  18   type(ieee_flag_type), parameter :: x(5) = &
  19     [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
  20       IEEE_UNDERFLOW, IEEE_INEXACT ]
  21   logical :: l(5) = .false.
  22   character(len=5) :: s
  23
  24 #define FLAGS_STRING(S) \
  25   call ieee_get_flag(x, l) ; \
  26   write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l)
  27
  28 #define CHECK_FLAGS(expected) \
  29   FLAGS_STRING(s) ; \
  30   if (s /= expected) then ; \
  31     write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \
  32     call abort ; \
  33   end if ; \
  34   call check_flag_sub
  35
  36   real :: sx
  37   double precision :: dx
  38
  39   ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG
  40
  41   !!!! IEEE float
  42
  43   ! Initial flags are all off
  44   CHECK_FLAGS("     ")
  45
  46   ! Check we can clear them
  47   call ieee_set_flag(ieee_all, .false.)
  48   CHECK_FLAGS("     ")
  49
  50   ! Raise invalid, then clear
  51   sx = -1
  52   call use_real(sx)
  53   sx = sqrt(sx)
  54   call use_real(sx)
  55   CHECK_FLAGS("I    ")
  56   call ieee_set_flag(ieee_all, .false.)
  57   CHECK_FLAGS("     ")
  58
  59   ! Raise overflow and precision
  60   sx = huge(sx)
  61   CHECK_FLAGS("     ")
  62   sx = sx*sx
  63   CHECK_FLAGS(" O  P")
  64   call use_real(sx)
  65
  66   ! Also raise divide-by-zero
  67   sx = 0
  68   sx = 1 / sx
  69   CHECK_FLAGS(" OZ P")
  70   call use_real(sx)
  71
  72   ! Clear them
  73   call ieee_set_flag([ieee_overflow,ieee_inexact,&
  74                       ieee_divide_by_zero],[.false.,.false.,.true.])
  75   CHECK_FLAGS("  Z  ")
  76   call ieee_set_flag(ieee_divide_by_zero, .false.)
  77   CHECK_FLAGS("     ")
  78
  79   ! Raise underflow
  80   sx = tiny(sx)
  81   CHECK_FLAGS("     ")
  82   sx = sx / 10
  83   call use_real(sx)
  84   CHECK_FLAGS("   UP")
  85
  86   ! Raise everything
  87   call ieee_set_flag(ieee_all, .true.)
  88   CHECK_FLAGS("IOZUP")
  89
  90   ! And clear
  91   call ieee_set_flag(ieee_all, .false.)
  92   CHECK_FLAGS("     ")
  93
  94   !!!! IEEE double
  95
  96   ! Initial flags are all off
  97   CHECK_FLAGS("     ")
  98
  99   ! Check we can clear them
 100   call ieee_set_flag(ieee_all, .false.)
 101   CHECK_FLAGS("     ")
 102
 103   ! Raise invalid, then clear
 104   dx = -1
 105   call use_real(dx)
 106   dx = sqrt(dx)
 107   call use_real(dx)
 108   CHECK_FLAGS("I    ")
 109   call ieee_set_flag(ieee_all, .false.)
 110   CHECK_FLAGS("     ")
 111
 112   ! Raise overflow and precision
 113   dx = huge(dx)
 114   CHECK_FLAGS("     ")
 115   dx = dx*dx
 116   CHECK_FLAGS(" O  P")
 117   call use_real(dx)
 118
 119   ! Also raise divide-by-zero
 120   dx = 0
 121   dx = 1 / dx
 122   CHECK_FLAGS(" OZ P")
 123   call use_real(dx)
 124
 125   ! Clear them
 126   call ieee_set_flag([ieee_overflow,ieee_inexact,&
 127                       ieee_divide_by_zero],[.false.,.false.,.true.])
 128   CHECK_FLAGS("  Z  ")
 129   call ieee_set_flag(ieee_divide_by_zero, .false.)
 130   CHECK_FLAGS("     ")
 131
 132   ! Raise underflow
 133   dx = tiny(dx)
 134   CHECK_FLAGS("     ")
 135   dx = dx / 10
 136   CHECK_FLAGS("   UP")
 137   call use_real(dx)
 138
 139   ! Raise everything
 140   call ieee_set_flag(ieee_all, .true.)
 141   CHECK_FLAGS("IOZUP")
 142
 143   ! And clear
 144   call ieee_set_flag(ieee_all, .false.)
 145   CHECK_FLAGS("     ")
 146
 147 contains
 148
 149   subroutine check_flag_sub
 150     use ieee_exceptions
 151     logical :: l(5) = .false.
 152     type(ieee_flag_type), parameter :: x(5) = &
 153       [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
 154         IEEE_UNDERFLOW, IEEE_INEXACT ]
 155     call ieee_get_flag(x, l)
 156
 157     if (any(l)) then
 158       print *, "Flags not cleared in subroutine"
 159       call abort
 160     end if
 161   end subroutine
 162
 163   ! Interface to a routine that avoids calculations to be optimized out,
 164   ! making it appear that we use the result
 165   subroutine use_real_4(x)
 166     real :: x
 167     if (x == 123456.789) print *, "toto"
 168   end subroutine
 169   subroutine use_real_8(x)
 170     double precision :: x
 171     if (x == 123456.789) print *, "toto"
 172   end subroutine
 173
 174 end