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