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), haltworks 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 haltworks = ieee_support_halting(ieee_overflow) 22 23 call ieee_get_status(s1) 24 call ieee_set_status(s1) 25 26 call ieee_get_flag(ieee_all, flags) 27 if (any(flags)) STOP 1 28 call ieee_get_rounding_mode(mode) 29 if (mode /= ieee_down) STOP 2 30 call ieee_get_halting_mode(ieee_all, halt) 31 if (any(halt)) STOP 3 32 33 call ieee_set_rounding_mode(ieee_to_zero) 34 call ieee_set_flag(ieee_underflow, .true.) 35 call ieee_set_halting_mode(ieee_overflow, .true.) 36 x = -1 37 x = sqrt(x) 38 if (.not. ieee_is_nan(x)) STOP 4 39 40 call ieee_get_status(s2) 41 42 call ieee_get_flag(ieee_all, flags) 43 if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & 44 .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & 45 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & 46 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 5 47 call ieee_get_rounding_mode(mode) 48 if (mode /= ieee_to_zero) STOP 6 49 call ieee_get_halting_mode(ieee_all, halt) 50 if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 7 51 52 call ieee_set_status(s2) 53 54 call ieee_get_flag(ieee_all, flags) 55 if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & 56 .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & 57 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & 58 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 8 59 call ieee_get_rounding_mode(mode) 60 if (mode /= ieee_to_zero) STOP 9 61 call ieee_get_halting_mode(ieee_all, halt) 62 if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 10 63 64 call ieee_set_status(s1) 65 66 call ieee_get_flag(ieee_all, flags) 67 if (any(flags)) STOP 11 68 call ieee_get_rounding_mode(mode) 69 if (mode /= ieee_down) STOP 12 70 call ieee_get_halting_mode(ieee_all, halt) 71 if (any(halt)) STOP 13 72 73 call ieee_set_status(s2) 74 75 call ieee_get_flag(ieee_all, flags) 76 if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & 77 .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & 78 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & 79 .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 14 80 call ieee_get_rounding_mode(mode) 81 if (mode /= ieee_to_zero) STOP 15 82 call ieee_get_halting_mode(ieee_all, halt) 83 if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 16 84 85end 86