Hi,
this test case fails very often, and the reason is not in GCC but
in a missing glibc rounding support for strtod.
This patch fixes the test case, to first determine if the
rounding support is available. This is often the case for real(16)
thru the libquadmath. So even in cases where the test case usually
fails it still tests something with this patch.
Ok for trunk?
Regards
Bernd Edlinger
2013-09-25 Bernd Edlinger <bernd.edlin...@hotmail.de>
PR fortran/58113
* gfortran.dg/round_4.f90: Check for rounding support.
--- gcc/testsuite/gfortran.dg/round_4.f90 2013-07-21 13:54:27.000000000
+0200
+++ gcc/testsuite/gfortran.dg/round_4.f90 2013-08-23 10:16:32.000000000
+0200
@@ -27,6 +27,17 @@
real(xp) :: r10p, r10m, ref10u, ref10d
real(qp) :: r16p, r16m, ref16u, ref16d
character(len=20) :: str, round
+ logical :: rnd4, rnd8, rnd10, rnd16
+
+ ! Test for which types glibc's strtod function supports rounding
+ str = '0.01 0.01 0.01 0.01'
+ read (str, *, round='up') r4p, r8p, r10p, r16p
+ read (str, *, round='down') r4m, r8m, r10m, r16m
+ rnd4 = r4p /= r4m
+ rnd8 = r8p /= r8m
+ rnd10 = r10p /= r10m
+ rnd16 = r16p /= r16m
+! write (*, *) rnd4, rnd8, rnd10, rnd16
ref4u = 0.100000001_4
ref8u = 0.10000000000000001_8
@@ -55,40 +66,40 @@
round = 'up'
call t()
- if (r4p /= ref4u .or. r4m /= -ref4d) call abort()
- if (r8p /= ref8u .or. r8m /= -ref8d) call abort()
- if (r10p /= ref10u .or. r10m /= -ref10d) call abort()
- if (r16p /= ref16u .or. r16m /= -ref16d) call abort()
+ if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4d)) call abort()
+ if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8d)) call abort()
+ if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10d)) call abort()
+ if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16d)) call abort()
round = 'down'
call t()
- if (r4p /= ref4d .or. r4m /= -ref4u) call abort()
- if (r8p /= ref8d .or. r8m /= -ref8u) call abort()
- if (r10p /= ref10d .or. r10m /= -ref10u) call abort()
- if (r16p /= ref16d .or. r16m /= -ref16u) call abort()
+ if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4u)) call abort()
+ if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8u)) call abort()
+ if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10u)) call abort()
+ if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16u)) call abort()
round = 'zero'
call t()
- if (r4p /= ref4d .or. r4m /= -ref4d) call abort()
- if (r8p /= ref8d .or. r8m /= -ref8d) call abort()
- if (r10p /= ref10d .or. r10m /= -ref10d) call abort()
- if (r16p /= ref16d .or. r16m /= -ref16d) call abort()
+ if (rnd4 .and. (r4p /= ref4d .or. r4m /= -ref4d)) call abort()
+ if (rnd8 .and. (r8p /= ref8d .or. r8m /= -ref8d)) call abort()
+ if (rnd10 .and. (r10p /= ref10d .or. r10m /= -ref10d)) call abort()
+ if (rnd16 .and. (r16p /= ref16d .or. r16m /= -ref16d)) call abort()
round = 'nearest'
call t()
- if (r4p /= ref4u .or. r4m /= -ref4u) call abort()
- if (r8p /= ref8u .or. r8m /= -ref8u) call abort()
- if (r10p /= ref10u .or. r10m /= -ref10u) call abort()
- if (r16p /= ref16u .or. r16m /= -ref16u) call abort()
+ if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort()
+ if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort()
+ if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort()
+ if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort()
! Same as nearest (but rounding towards zero if there is a tie
! [does not apply here])
round = 'compatible'
call t()
- if (r4p /= ref4u .or. r4m /= -ref4u) call abort()
- if (r8p /= ref8u .or. r8m /= -ref8u) call abort()
- if (r10p /= ref10u .or. r10m /= -ref10u) call abort()
- if (r16p /= ref16u .or. r16m /= -ref16u) call abort()
+ if (rnd4 .and. (r4p /= ref4u .or. r4m /= -ref4u)) call abort()
+ if (rnd8 .and. (r8p /= ref8u .or. r8m /= -ref8u)) call abort()
+ if (rnd10 .and. (r10p /= ref10u .or. r10m /= -ref10u)) call abort()
+ if (rnd16 .and. (r16p /= ref16u .or. r16m /= -ref16u)) call abort()
contains
subroutine t()
! print *, round
