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

   1 ! { dg-do run }
   2 !
   3 ! This test will fail on older x86_64 glibc (< 2.20), due to this bug:
   4 ! https://sourceware.org/bugzilla/show_bug.cgi?id=16198
   5 ! We usually won't see it anyway, because on such systems x86_64 assembly
   6 ! (libgfortran/config/fpu-387.h) is used.
   7 !
   8   use :: ieee_arithmetic
   9   implicit none
  10
  11   type(ieee_status_type) :: s1, s2
  12   logical :: flags(5), halt(5)
  13   type(ieee_round_type) :: mode
  14   real :: x
  15
  16   ! Test IEEE_GET_STATUS and IEEE_SET_STATUS
  17
  18   call ieee_set_flag(ieee_all, .false.)
  19   call ieee_set_rounding_mode(ieee_down)
  20   call ieee_set_halting_mode(ieee_all, .false.)
  21
  22   call ieee_get_status(s1)
  23   call ieee_set_status(s1)
  24
  25   call ieee_get_flag(ieee_all, flags)
  26   if (any(flags)) call abort
  27   call ieee_get_rounding_mode(mode)
  28   if (mode /= ieee_down) call abort
  29   call ieee_get_halting_mode(ieee_all, halt)
  30   if (any(halt)) call abort
  31
  32   call ieee_set_rounding_mode(ieee_to_zero)
  33   call ieee_set_flag(ieee_underflow, .true.)
  34   call ieee_set_halting_mode(ieee_overflow, .true.)
  35   x = -1
  36   x = sqrt(x)
  37   if (.not. ieee_is_nan(x)) call abort
  38
  39   call ieee_get_status(s2)
  40
  41   call ieee_get_flag(ieee_all, flags)
  42   if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
  43              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
  44   call ieee_get_rounding_mode(mode)
  45   if (mode /= ieee_to_zero) call abort
  46   call ieee_get_halting_mode(ieee_all, halt)
  47   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  48
  49   call ieee_set_status(s2)
  50
  51   call ieee_get_flag(ieee_all, flags)
  52   if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
  53              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
  54   call ieee_get_rounding_mode(mode)
  55   if (mode /= ieee_to_zero) call abort
  56   call ieee_get_halting_mode(ieee_all, halt)
  57   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  58
  59   call ieee_set_status(s1)
  60
  61   call ieee_get_flag(ieee_all, flags)
  62   if (any(flags)) call abort
  63   call ieee_get_rounding_mode(mode)
  64   if (mode /= ieee_down) call abort
  65   call ieee_get_halting_mode(ieee_all, halt)
  66   if (any(halt)) call abort
  67
  68   call ieee_set_status(s2)
  69
  70   call ieee_get_flag(ieee_all, flags)
  71   if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
  72              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]))) call abort
  73   call ieee_get_rounding_mode(mode)
  74   if (mode /= ieee_to_zero) call abort
  75   call ieee_get_halting_mode(ieee_all, halt)
  76   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  77
  78 end