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

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