gcc/testsuite/gfortran.dg/fmt_en_rn.f90

   1 ! { dg-do run }
   2 ! PR60128 Invalid outputs with EN descriptors
   3 ! Test case provided by Walt Brainerd.
   4 program pr60128
   5 use ISO_FORTRAN_ENV
   6     implicit none
   7     integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]]
   8     logical :: l_skip(4) = .false.
   9     integer :: i
  10     integer :: n_tst = 0, n_cnt = 0, n_skip = 0
  11     character(len=20,kind=4) :: s, s1
  12
  13 !   Check that the default rounding mode is to nearest and to even on tie.
  14     do i=1,size(real_kinds)
  15       if (i == 1) then
  16         write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), &
  17                                   real(9.49999905,kind=j(1)),  &
  18                                   real(9.5,kind=j(1)), real(8.5,kind=j(1))
  19         write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), &
  20                                        real(98765.0,kind=j(1))
  21       else if (i == 2) then
  22         write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), &
  23                                   real(9.49999905,kind=j(2)),  &
  24                                   real(9.5,kind=j(2)), real(8.5,kind=j(2))
  25         write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), &
  26                                        real(98765.0,kind=j(2))
  27       else if (i == 3) then
  28         write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), &
  29                                   real(9.49999905,kind=j(3)),  &
  30                                   real(9.5,kind=j(3)), real(8.5,kind=j(3))
  31         write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), &
  32                                        real(98765.0,kind=j(3))
  33       else if (i == 4) then
  34         write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), &
  35                                   real(9.49999905,kind=j(4)),  &
  36                                   real(9.5,kind=j(4)), real(8.5,kind=j(4))
  37         write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), &
  38                                        real(98765.0,kind=j(4))
  39       end if
  40       if (s /= 4_'-9.5 9.5 10.  8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then
  41         l_skip(i) = .true.
  42         print "('Unsupported rounding for real(',i0,')')", j(i)
  43       end if
  44     end do
  45
  46
  47 ! Original test.
  48     call checkfmt("(en15.2)", -.44444,    4_"    -444.44E-03")
  49
  50 ! Test for the bug in comment 6.
  51     call checkfmt("(rn,en15.0)", 1.0,        4_"         1.E+00")
  52     call checkfmt("(rn,en15.0)", 1.00000012, 4_"         1.E+00")
  53     call checkfmt("(rn,en15.0)", 0.99999994, 4_"         1.E+00")
  54     call checkfmt("(rn,en15.0)", 10.0,       4_"        10.E+00")
  55     call checkfmt("(rn,en15.0)", 10.0000010, 4_"        10.E+00")
  56     call checkfmt("(rn,en15.0)", 9.99999905, 4_"        10.E+00")
  57     call checkfmt("(rn,en15.0)", 100.0,      4_"       100.E+00")
  58     call checkfmt("(rn,en15.0)", 100.000008, 4_"       100.E+00")
  59     call checkfmt("(rn,en15.0)", 99.9999924, 4_"       100.E+00")
  60     call checkfmt("(rn,en15.0)", 1000.0,     4_"         1.E+03")
  61     call checkfmt("(rn,en15.0)", 1000.00006, 4_"         1.E+03")
  62     call checkfmt("(rn,en15.0)", 999.999939, 4_"         1.E+03")
  63     call checkfmt("(rn,en15.0)", 9.5,        4_"        10.E+00")
  64     call checkfmt("(rn,en15.0)", 9.50000095, 4_"        10.E+00")
  65     call checkfmt("(rn,en15.0)", 9.49999905, 4_"         9.E+00")
  66     call checkfmt("(rn,en15.0)", 99.5,       4_"       100.E+00")
  67     call checkfmt("(rn,en15.0)", 99.5000076, 4_"       100.E+00")
  68     call checkfmt("(rn,en15.0)", 99.4999924, 4_"        99.E+00")
  69     call checkfmt("(rn,en15.0)", 999.5,      4_"         1.E+03")
  70     call checkfmt("(rn,en15.0)", 999.500061, 4_"         1.E+03")
  71     call checkfmt("(rn,en15.0)", 999.499939, 4_"       999.E+00")
  72     call checkfmt("(rn,en15.0)", 9500.0,     4_"        10.E+03")
  73     call checkfmt("(rn,en15.0)", 9500.00098, 4_"        10.E+03")
  74     call checkfmt("(rn,en15.0)", 9499.99902, 4_"         9.E+03")
  75     call checkfmt("(rn,en15.1)", 9950.0,     4_"       10.0E+03")
  76     call checkfmt("(rn,en15.2)", 9995.0,     4_"      10.00E+03")
  77     call checkfmt("(rn,en15.3)", 9999.5,     4_"     10.000E+03")
  78     call checkfmt("(rn,en15.1)", 9.5,        4_"        9.5E+00")
  79     call checkfmt("(rn,en15.1)", 9.50000095, 4_"        9.5E+00")
  80     call checkfmt("(rn,en15.1)", 9.49999905, 4_"        9.5E+00")
  81     call checkfmt("(rn,en15.1)", 0.099951,   4_"      100.0E-03")
  82     call checkfmt("(rn,en15.1)", 0.009951,   4_"       10.0E-03")
  83     call checkfmt("(rn,en15.1)", 0.000999951,4_"        1.0E-03")
  84
  85     call checkfmt("(rn,en15.0)", -1.0,        4_"        -1.E+00")
  86     call checkfmt("(rn,en15.0)", -1.00000012, 4_"        -1.E+00")
  87     call checkfmt("(rn,en15.0)", -0.99999994, 4_"        -1.E+00")
  88     call checkfmt("(rn,en15.0)", -10.0,       4_"       -10.E+00")
  89     call checkfmt("(rn,en15.0)", -10.0000010, 4_"       -10.E+00")
  90     call checkfmt("(rn,en15.0)", -9.99999905, 4_"       -10.E+00")
  91     call checkfmt("(rn,en15.0)", -100.0,      4_"      -100.E+00")
  92     call checkfmt("(rn,en15.0)", -100.000008, 4_"      -100.E+00")
  93     call checkfmt("(rn,en15.0)", -99.9999924, 4_"      -100.E+00")
  94     call checkfmt("(rn,en15.0)", -1000.0,     4_"        -1.E+03")
  95     call checkfmt("(rn,en15.0)", -1000.00006, 4_"        -1.E+03")
  96     call checkfmt("(rn,en15.0)", -999.999939, 4_"        -1.E+03")
  97     call checkfmt("(rn,en15.0)", -9.5,        4_"       -10.E+00")
  98     call checkfmt("(rn,en15.0)", -9.50000095, 4_"       -10.E+00")
  99     call checkfmt("(rn,en15.0)", -9.49999905, 4_"        -9.E+00")
 100     call checkfmt("(rn,en15.0)", -99.5,       4_"      -100.E+00")
 101     call checkfmt("(rn,en15.0)", -99.5000076, 4_"      -100.E+00")
 102     call checkfmt("(rn,en15.0)", -99.4999924, 4_"       -99.E+00")
 103     call checkfmt("(rn,en15.0)", -999.5,      4_"        -1.E+03")
 104     call checkfmt("(rn,en15.0)", -999.500061, 4_"        -1.E+03")
 105     call checkfmt("(rn,en15.0)", -999.499939, 4_"      -999.E+00")
 106     call checkfmt("(rn,en15.0)", -9500.0,     4_"       -10.E+03")
 107     call checkfmt("(rn,en15.0)", -9500.00098, 4_"       -10.E+03")
 108     call checkfmt("(rn,en15.0)", -9499.99902, 4_"        -9.E+03")
 109     call checkfmt("(rn,en15.1)", -9950.0,     4_"      -10.0E+03")
 110     call checkfmt("(rn,en15.2)", -9995.0,     4_"     -10.00E+03")
 111     call checkfmt("(rn,en15.3)", -9999.5,     4_"    -10.000E+03")
 112     call checkfmt("(rn,en15.1)", -9.5,        4_"       -9.5E+00")
 113     call checkfmt("(rn,en15.1)", -9.50000095, 4_"       -9.5E+00")
 114     call checkfmt("(rn,en15.1)", -9.49999905, 4_"       -9.5E+00")
 115     call checkfmt("(rn,en15.1)", -0.099951,   4_"     -100.0E-03")
 116     call checkfmt("(rn,en15.1)", -0.009951,   4_"      -10.0E-03")
 117     call checkfmt("(rn,en15.1)", -0.000999951,4_"       -1.0E-03")
 118
 119     call checkfmt("(rn,en15.1)", 987350.,     4_"      987.4E+03")
 120     call checkfmt("(rn,en15.2)", 98735.,      4_"      98.74E+03")
 121     call checkfmt("(rn,en15.3)", 9873.5,      4_"      9.874E+03")
 122     call checkfmt("(rn,en15.1)", 987650.,     4_"      987.6E+03")
 123     call checkfmt("(rn,en15.2)", 98765.,      4_"      98.76E+03")
 124     call checkfmt("(rn,en15.3)", 9876.5,      4_"      9.876E+03")
 125     call checkfmt("(rn,en15.1)", 3.125E-02,   4_"       31.2E-03")
 126     call checkfmt("(rn,en15.1)", 9.375E-02,   4_"       93.8E-03")
 127     call checkfmt("(rn,en15.2)", 1.5625E-02,  4_"      15.62E-03")
 128     call checkfmt("(rn,en15.2)", 4.6875E-02,  4_"      46.88E-03")
 129     call checkfmt("(rn,en15.3)", 7.8125E-03,  4_"      7.812E-03")
 130     call checkfmt("(rn,en15.3)", 2.34375E-02, 4_"     23.438E-03")
 131     call checkfmt("(rn,en15.3)", 9.765625E-04,4_"    976.562E-06")
 132     call checkfmt("(rn,en15.6)", 2.9296875E-03,4_"   2.929688E-03")
 133
 134     call checkfmt("(rn,en15.1)", -987350.,     4_"     -987.4E+03")
 135     call checkfmt("(rn,en15.2)", -98735.,      4_"     -98.74E+03")
 136     call checkfmt("(rn,en15.3)", -9873.5,      4_"     -9.874E+03")
 137     call checkfmt("(rn,en15.1)", -987650.,     4_"     -987.6E+03")
 138     call checkfmt("(rn,en15.2)", -98765.,      4_"     -98.76E+03")
 139     call checkfmt("(rn,en15.3)", -9876.5,      4_"     -9.876E+03")
 140     call checkfmt("(rn,en15.1)", -3.125E-02,   4_"      -31.2E-03")
 141     call checkfmt("(rn,en15.1)", -9.375E-02,   4_"      -93.8E-03")
 142     call checkfmt("(rn,en15.2)", -1.5625E-02,  4_"     -15.62E-03")
 143     call checkfmt("(rn,en15.2)", -4.6875E-02,  4_"     -46.88E-03")
 144     call checkfmt("(rn,en15.3)", -7.8125E-03,  4_"     -7.812E-03")
 145     call checkfmt("(rn,en15.3)", -2.34375E-02, 4_"    -23.438E-03")
 146     call checkfmt("(rn,en15.3)", -9.765625E-04,4_"   -976.562E-06")
 147     call checkfmt("(rn,en15.6)", -2.9296875E-03,4_"  -2.929688E-03")
 148
 149     print *, n_tst, n_cnt, n_skip
 150     if (n_cnt /= 0) stop n_cnt
 151     if (all(.not. l_skip)) print *, "All kinds rounded to nearest"
 152
 153 contains
 154     subroutine checkfmt(fmt, x, cmp)
 155         implicit none
 156         integer :: i
 157         character(len=*), intent(in) :: fmt
 158         real, intent(in) :: x
 159         character(len=*, kind=4), intent(in) :: cmp
 160         do i=1,size(real_kinds)
 161           if (l_skip(i)) cycle
 162           if (i == 1) then
 163             write(s, fmt) real(x,kind=j(1))
 164           else if (i == 2) then
 165             write(s, fmt) real(x,kind=j(2))
 166           else if (i == 3) then
 167             write(s, fmt) real(x,kind=j(3))
 168           else if (i == 4) then
 169             write(s, fmt) real(x,kind=j(4))
 170           end if
 171           n_tst = n_tst + 1
 172           if (s /= cmp) then
 173             if (l_skip(i)) then
 174               n_skip = n_skip + 1
 175             else
 176               print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp
 177               n_cnt = n_cnt + 1
 178             end if
 179           end if
 180         end do
 181
 182     end subroutine
 183 end program
 184 ! { dg-output "All kinds rounded to nearest" { xfail hppa*-*-hpux* } }
 185 ! { dg-final { cleanup-saved-temps } }