gcc/testsuite/gfortran.dg/round_4.f90

   1 ! { dg-do run { xfail i386-*-freebsd* } }
   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 !
  24 program 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()
 111 contains
 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
 121 end program main