1! { dg-do run } 2! { dg-add-options ieee } 3! { dg-skip-if "PR libfortran/58015" { hppa*-*-hpux* } } 4! { dg-skip-if "IBM long double 31 bits of precision, test requires 38" { powerpc*-*-linux* } } 5! 6! PR fortran/35862 7! 8! Test whether I/O rounding works. Uses internally (libgfortran) strtod 9! for the conversion - and sets the CPU rounding mode accordingly. 10! 11! Only few strtod implementations currently support rounding. Therefore 12! we use a heuristic to determine if the rounding support is available. 13! The assumption is that if strtod gives *different* results for up/down 14! rounding, then it will give *correct* results for nearest/zero/up/down 15! rounding too. And that is what is effectively checked. 16! 17! If it doesn't work on your system, please check whether strtod handles 18! rounding correctly and whether your system is supported in 19! libgfortran/config/fpu*.c 20! 21! Please only add ... run { target { ! { triplets } } } if it is unfixable 22! on your target - and a note why (strtod has broken rounding support, etc.) 23! 24program main 25 use iso_fortran_env 26 implicit none 27 28 ! The following uses kinds=10 and 16 if available or 29 ! 8 and 10 - or 8 and 16 - or 4 and 8. 30 integer, parameter :: xp = real_kinds(ubound(real_kinds,dim=1)-1) 31 integer, parameter :: qp = real_kinds(ubound(real_kinds,dim=1)) 32 33 real(4) :: r4p, r4m, ref4u, ref4d 34 real(8) :: r8p, r8m, ref8u, ref8d 35 real(xp) :: r10p, r10m, ref10u, ref10d 36 real(qp) :: r16p, r16m, ref16u, ref16d 37 character(len=20) :: str, round 38 logical :: rnd4, rnd8, rnd10, rnd16 39 40 ! Test for which types glibc's strtod function supports rounding 41 str = '0.01 0.01 0.01 0.01' 42 read (str, *, round='up') r4p, r8p, r10p, r16p 43 read (str, *, round='down') r4m, r8m, r10m, r16m 44 rnd4 = r4p /= r4m 45 rnd8 = r8p /= r8m 46 rnd10 = r10p /= r10m 47 rnd16 = r16p /= r16m 48! write (*, *) rnd4, rnd8, rnd10, rnd16 49 50 ref4u = 0.100000001_4 51 ref8u = 0.10000000000000001_8 52 53 if (xp == 4) then 54 ref10u = 0.100000001_xp 55 elseif (xp == 8) then 56 ref10u = 0.10000000000000001_xp 57 else ! xp == 10 58 ref10u = 0.1000000000000000000014_xp 59 end if 60 61 if (qp == 8) then 62 ref16u = 0.10000000000000001_qp 63 elseif (qp == 10) then 64 ref16u = 0.1000000000000000000014_qp 65 else ! qp == 16 66 ref16u = 0.10000000000000000000000000000000000481_qp 67 end if 68 69 ! ref*d = 9.999999... 70 ref4d = nearest (ref4u, -1.0_4) 71 ref8d = nearest (ref8u, -1.0_8) 72 ref10d = nearest (ref10u, -1.0_xp) 73 ref16d = nearest (ref16u, -1.0_qp) 74 75 round = 'up' 76 call t() 77 if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4d)) call abort() 78 if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8d)) call abort() 79 if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10d)) call abort() 80 if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16d)) call abort() 81 82 round = 'down' 83 call t() 84 if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4u)) call abort() 85 if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8u)) call abort() 86 if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10u)) call abort() 87 if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16u)) call abort() 88 89 round = 'zero' 90 call t() 91 if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4d)) call abort() 92 if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8d)) call abort() 93 if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10d)) call abort() 94 if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16d)) call abort() 95 96 round = 'nearest' 97 call t() 98 if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort() 99 if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort() 100 if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort() 101 if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort() 102 103! Same as nearest (but rounding towards zero if there is a tie 104! [does not apply here]) 105 round = 'compatible' 106 call t() 107 if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort() 108 if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort() 109 if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort() 110 if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort() 111contains 112 subroutine t() 113! print *, round 114 str = "0.1 0.1 0.1 0.1" 115 read (str, *,round=round) r4p, r8p, r10p, r16p 116! write (*, '(*(g0:" "))') r4p, r8p, r10p, r16p 117 str = "-0.1 -0.1 -0.1 -0.1" 118 read (str, *,round=round) r4m, r8m, r10m, r16m 119! write (*, *) r4m, r8m, r10m, r16m 120 end subroutine t 121end program main 122