gcc/testsuite/gfortran.dg/round_4.f90

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