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.,.true.,.true.]) &
  44              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
  45              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
  46   call ieee_get_rounding_mode(mode)
  47   if (mode /= ieee_to_zero) call abort
  48   call ieee_get_halting_mode(ieee_all, halt)
  49   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  50
  51   call ieee_set_status(s2)
  52
  53   call ieee_get_flag(ieee_all, flags)
  54   if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
  55              .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) &
  56              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
  57              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
  58   call ieee_get_rounding_mode(mode)
  59   if (mode /= ieee_to_zero) call abort
  60   call ieee_get_halting_mode(ieee_all, halt)
  61   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  62
  63   call ieee_set_status(s1)
  64
  65   call ieee_get_flag(ieee_all, flags)
  66   if (any(flags)) call abort
  67   call ieee_get_rounding_mode(mode)
  68   if (mode /= ieee_down) call abort
  69   call ieee_get_halting_mode(ieee_all, halt)
  70   if (any(halt)) call abort
  71
  72   call ieee_set_status(s2)
  73
  74   call ieee_get_flag(ieee_all, flags)
  75   if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) &
  76              .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) &
  77              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) &
  78              .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) call abort
  79   call ieee_get_rounding_mode(mode)
  80   if (mode /= ieee_to_zero) call abort
  81   call ieee_get_halting_mode(ieee_all, halt)
  82   if ((.not. halt(1)) .or. any(halt(2:))) call abort
  83
  84 end