gcc/testsuite/gfortran.dg/ieee/large_3.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
   9   use ieee_exceptions
  10   use ieee_arithmetic
  11
  12   implicit none
  13
  14   ! k1 and k2 will be large real kinds, if supported, and single/double
  15   ! otherwise
  16   integer, parameter :: k1 = &
  17     max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
  18   integer, parameter :: k2 = &
  19     max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))
  20
  21   type(ieee_flag_type), parameter :: x(5) = &
  22     [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
  23       IEEE_UNDERFLOW, IEEE_INEXACT ]
  24   logical :: l(5) = .false.
  25   character(len=5) :: s
  26
  27 #define FLAGS_STRING(S) \
  28   call ieee_get_flag(x, l) ; \
  29   write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l)
  30
  31 #define CHECK_FLAGS(expected) \
  32   FLAGS_STRING(s) ; \
  33   if (s /= expected) then ; \
  34     write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \
  35     call abort ; \
  36   end if ; \
  37   call check_flag_sub
  38
  39   real(kind=k1), volatile :: sx
  40   real(kind=k2), volatile :: dx
  41
  42   ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG
  43
  44   !!!! Large kind 1
  45
  46   ! Initial flags are all off
  47   CHECK_FLAGS("     ")
  48
  49   ! Check we can clear them
  50   call ieee_set_flag(ieee_all, .false.)
  51   CHECK_FLAGS("     ")
  52
  53   ! Raise invalid, then clear
  54   sx = -1
  55   sx = sqrt(sx)
  56   CHECK_FLAGS("I    ")
  57   call ieee_set_flag(ieee_all, .false.)
  58   CHECK_FLAGS("     ")
  59
  60   ! Raise overflow and precision
  61   sx = huge(sx)
  62   CHECK_FLAGS("     ")
  63   sx = sx*sx
  64   CHECK_FLAGS(" O  P")
  65
  66   ! Also raise divide-by-zero
  67   sx = 0
  68   sx = 1 / sx
  69   CHECK_FLAGS(" OZ P")
  70
  71   ! Clear them
  72   call ieee_set_flag([ieee_overflow,ieee_inexact,&
  73                       ieee_divide_by_zero],[.false.,.false.,.true.])
  74   CHECK_FLAGS("  Z  ")
  75   call ieee_set_flag(ieee_divide_by_zero, .false.)
  76   CHECK_FLAGS("     ")
  77
  78   ! Raise underflow
  79   sx = tiny(sx)
  80   CHECK_FLAGS("     ")
  81   sx = sx / 10
  82   CHECK_FLAGS("   UP")
  83
  84   ! Raise everything
  85   call ieee_set_flag(ieee_all, .true.)
  86   CHECK_FLAGS("IOZUP")
  87
  88   ! And clear
  89   call ieee_set_flag(ieee_all, .false.)
  90   CHECK_FLAGS("     ")
  91
  92
  93   !!!! Large kind 2
  94
  95   ! Initial flags are all off
  96   CHECK_FLAGS("     ")
  97
  98   ! Check we can clear them
  99   call ieee_set_flag(ieee_all, .false.)
 100   CHECK_FLAGS("     ")
 101
 102   ! Raise invalid, then clear
 103   dx = -1
 104   dx = sqrt(dx)
 105   CHECK_FLAGS("I    ")
 106   call ieee_set_flag(ieee_all, .false.)
 107   CHECK_FLAGS("     ")
 108
 109   ! Raise overflow and precision
 110   dx = huge(dx)
 111   CHECK_FLAGS("     ")
 112   dx = dx*dx
 113   CHECK_FLAGS(" O  P")
 114
 115   ! Also raise divide-by-zero
 116   dx = 0
 117   dx = 1 / dx
 118   CHECK_FLAGS(" OZ P")
 119
 120   ! Clear them
 121   call ieee_set_flag([ieee_overflow,ieee_inexact,&
 122                       ieee_divide_by_zero],[.false.,.false.,.true.])
 123   CHECK_FLAGS("  Z  ")
 124   call ieee_set_flag(ieee_divide_by_zero, .false.)
 125   CHECK_FLAGS("     ")
 126
 127   ! Raise underflow
 128   dx = tiny(dx)
 129   CHECK_FLAGS("     ")
 130   dx = dx / 10
 131   CHECK_FLAGS("   UP")
 132
 133   ! Raise everything
 134   call ieee_set_flag(ieee_all, .true.)
 135   CHECK_FLAGS("IOZUP")
 136
 137   ! And clear
 138   call ieee_set_flag(ieee_all, .false.)
 139   CHECK_FLAGS("     ")
 140
 141 contains
 142
 143   subroutine check_flag_sub
 144     use ieee_exceptions
 145     logical :: l(5) = .false.
 146     type(ieee_flag_type), parameter :: x(5) = &
 147       [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, &
 148         IEEE_UNDERFLOW, IEEE_INEXACT ]
 149     call ieee_get_flag(x, l)
 150
 151     if (any(l)) then
 152       print *, "Flags not cleared in subroutine"
 153       call abort
 154     end if
 155   end subroutine
 156
 157 end