gcc/testsuite/gfortran.dg/fmt_pf.f90

   1 ! { dg-do run }
   2 ! PR70235 Incorrect output with PF format.
   3 ! Test case provided by Antoine Gardeux.
   4 program pr70235
   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) :: 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 /= '-9.5 9.5 10.  8.' .or. s1 /= ' 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("(-6PF8.3)", 1.0e4,    "   0.010")
  49     call checkfmt("(-6PF8.3)",   0.0,    "   0.000")
  50
  51 ! Test for the bug in comment 6.
  52     call checkfmt("(-8pf18.3)", 643.125, "             0.000")
  53     call checkfmt("(-7pf18.3)", 643.125, "             0.000")
  54     call checkfmt("(-6pf18.3)", 643.125, "             0.001")
  55     call checkfmt("(-5pf18.3)", 643.125, "             0.006")
  56     call checkfmt("(-4pf18.3)", 643.125, "             0.064")
  57     call checkfmt("(-3pf18.3)", 643.125, "             0.643")
  58     call checkfmt("(-2pf18.3)", 643.125, "             6.431")
  59     call checkfmt("(-1pf18.3)", 643.125, "            64.312")
  60     call checkfmt("( 0pf18.3)", 643.125, "           643.125")
  61
  62     call checkfmt("(ru,-8pf18.3)", 643.125, "             0.001")
  63     call checkfmt("(ru,-7pf18.3)", 643.125, "             0.001")
  64     call checkfmt("(ru,-6pf18.3)", 643.125, "             0.001")
  65     call checkfmt("(ru,-5pf18.3)", 643.125, "             0.007")
  66     call checkfmt("(ru,-4pf18.3)", 643.125, "             0.065")
  67     call checkfmt("(ru,-3pf18.3)", 643.125, "             0.644")
  68     call checkfmt("(ru,-2pf18.3)", 643.125, "             6.432")
  69     call checkfmt("(ru,-1pf18.3)", 643.125, "            64.313")
  70     call checkfmt("(ru, 0pf18.3)", 643.125, "           643.125")
  71
  72     call checkfmt("(rd,-8pf18.3)", 643.125, "             0.000")
  73     call checkfmt("(rd,-7pf18.3)", 643.125, "             0.000")
  74     call checkfmt("(rd,-6pf18.3)", 643.125, "             0.000")
  75     call checkfmt("(rd,-5pf18.3)", 643.125, "             0.006")
  76     call checkfmt("(rd,-4pf18.3)", 643.125, "             0.064")
  77     call checkfmt("(rd,-3pf18.3)", 643.125, "             0.643")
  78     call checkfmt("(rd,-2pf18.3)", 643.125, "             6.431")
  79     call checkfmt("(rd,-1pf18.3)", 643.125, "            64.312")
  80     call checkfmt("(rd, 0pf18.3)", 643.125, "           643.125")
  81
  82     call checkfmt("(rz,-8pf18.3)", 643.125, "             0.000")
  83     call checkfmt("(rz,-7pf18.3)", 643.125, "             0.000")
  84     call checkfmt("(rz,-6pf18.3)", 643.125, "             0.000")
  85     call checkfmt("(rz,-5pf18.3)", 643.125, "             0.006")
  86     call checkfmt("(rz,-4pf18.3)", 643.125, "             0.064")
  87     call checkfmt("(rz,-3pf18.3)", 643.125, "             0.643")
  88     call checkfmt("(rz,-2pf18.3)", 643.125, "             6.431")
  89     call checkfmt("(rz,-1pf18.3)", 643.125, "            64.312")
  90     call checkfmt("(rz, 0pf18.3)", 643.125, "           643.125")
  91
  92     call checkfmt("(rc,-8pf18.3)", 643.125, "             0.000")
  93     call checkfmt("(rc,-7pf18.3)", 643.125, "             0.000")
  94     call checkfmt("(rc,-6pf18.3)", 643.125, "             0.001")
  95     call checkfmt("(rc,-5pf18.3)", 643.125, "             0.006")
  96     call checkfmt("(rc,-4pf18.3)", 643.125, "             0.064")
  97     call checkfmt("(rc,-3pf18.3)", 643.125, "             0.643")
  98     call checkfmt("(rc,-2pf18.3)", 643.125, "             6.431")
  99     call checkfmt("(rc,-1pf18.3)", 643.125, "            64.313")
 100     call checkfmt("(rc, 0pf18.3)", 643.125, "           643.125")
 101
 102     call checkfmt("(rn,-8pf18.3)", 643.125, "             0.000")
 103     call checkfmt("(rn,-7pf18.3)", 643.125, "             0.000")
 104     call checkfmt("(rn,-6pf18.3)", 643.125, "             0.001")
 105     call checkfmt("(rn,-5pf18.3)", 643.125, "             0.006")
 106     call checkfmt("(rn,-4pf18.3)", 643.125, "             0.064")
 107     call checkfmt("(rn,-3pf18.3)", 643.125, "             0.643")
 108     call checkfmt("(rn,-2pf18.3)", 643.125, "             6.431")
 109     call checkfmt("(rn,-1pf18.3)", 643.125, "            64.312")
 110     call checkfmt("(rn, 0pf18.3)", 643.125, "           643.125")
 111
 112     call checkfmt("(rp,-8pf18.3)", 643.125, "             0.000")
 113     call checkfmt("(rp,-7pf18.3)", 643.125, "             0.000")
 114     call checkfmt("(rp,-6pf18.3)", 643.125, "             0.001")
 115     call checkfmt("(rp,-5pf18.3)", 643.125, "             0.006")
 116     call checkfmt("(rp,-4pf18.3)", 643.125, "             0.064")
 117     call checkfmt("(rp,-3pf18.3)", 643.125, "             0.643")
 118     call checkfmt("(rp,-2pf18.3)", 643.125, "             6.431")
 119     call checkfmt("(rp,-1pf18.3)", 643.125, "            64.312")
 120     call checkfmt("(rp, 0pf18.3)", 643.125, "           643.125")
 121
 122     call checkfmt("(-8pf18.3)", -643.125, "            -0.000")
 123     call checkfmt("(-7pf18.3)", -643.125, "            -0.000")
 124     call checkfmt("(-6pf18.3)", -643.125, "            -0.001")
 125     call checkfmt("(-5pf18.3)", -643.125, "            -0.006")
 126     call checkfmt("(-4pf18.3)", -643.125, "            -0.064")
 127     call checkfmt("(-3pf18.3)", -643.125, "            -0.643")
 128     call checkfmt("(-2pf18.3)", -643.125, "            -6.431")
 129     call checkfmt("(-1pf18.3)", -643.125, "           -64.312")
 130     call checkfmt("( 0pf18.3)", -643.125, "          -643.125")
 131
 132     call checkfmt("(ru,-8pf18.3)", -643.125, "            -0.000")
 133     call checkfmt("(ru,-7pf18.3)", -643.125, "            -0.000")
 134     call checkfmt("(ru,-6pf18.3)", -643.125, "            -0.000")
 135     call checkfmt("(ru,-5pf18.3)", -643.125, "            -0.006")
 136     call checkfmt("(ru,-4pf18.3)", -643.125, "            -0.064")
 137     call checkfmt("(ru,-3pf18.3)", -643.125, "            -0.643")
 138     call checkfmt("(ru,-2pf18.3)", -643.125, "            -6.431")
 139     call checkfmt("(ru,-1pf18.3)", -643.125, "           -64.312")
 140     call checkfmt("(ru, 0pf18.3)", -643.125, "          -643.125")
 141
 142     call checkfmt("(rd,-8pf18.3)", -643.125, "            -0.001")
 143     call checkfmt("(rd,-7pf18.3)", -643.125, "            -0.001")
 144     call checkfmt("(rd,-6pf18.3)", -643.125, "            -0.001")
 145     call checkfmt("(rd,-5pf18.3)", -643.125, "            -0.007")
 146     call checkfmt("(rd,-4pf18.3)", -643.125, "            -0.065")
 147     call checkfmt("(rd,-3pf18.3)", -643.125, "            -0.644")
 148     call checkfmt("(rd,-2pf18.3)", -643.125, "            -6.432")
 149     call checkfmt("(rd,-1pf18.3)", -643.125, "           -64.313")
 150     call checkfmt("(rd, 0pf18.3)", -643.125, "          -643.125")
 151
 152     call checkfmt("(rz,-8pf18.3)", -643.125, "            -0.000")
 153     call checkfmt("(rz,-7pf18.3)", -643.125, "            -0.000")
 154     call checkfmt("(rz,-6pf18.3)", -643.125, "            -0.000")
 155     call checkfmt("(rz,-5pf18.3)", -643.125, "            -0.006")
 156     call checkfmt("(rz,-4pf18.3)", -643.125, "            -0.064")
 157     call checkfmt("(rz,-3pf18.3)", -643.125, "            -0.643")
 158     call checkfmt("(rz,-2pf18.3)", -643.125, "            -6.431")
 159     call checkfmt("(rz,-1pf18.3)", -643.125, "           -64.312")
 160     call checkfmt("(rz, 0pf18.3)", -643.125, "          -643.125")
 161
 162     call checkfmt("(rc,-8pf18.3)", -643.125, "            -0.000")
 163     call checkfmt("(rc,-7pf18.3)", -643.125, "            -0.000")
 164     call checkfmt("(rc,-6pf18.3)", -643.125, "            -0.001")
 165     call checkfmt("(rc,-5pf18.3)", -643.125, "            -0.006")
 166     call checkfmt("(rc,-4pf18.3)", -643.125, "            -0.064")
 167     call checkfmt("(rc,-3pf18.3)", -643.125, "            -0.643")
 168     call checkfmt("(rc,-2pf18.3)", -643.125, "            -6.431")
 169     call checkfmt("(rc,-1pf18.3)", -643.125, "           -64.313")
 170     call checkfmt("(rc, 0pf18.3)", -643.125, "          -643.125")
 171
 172     call checkfmt("(rn,-8pf18.3)", -643.125, "            -0.000")
 173     call checkfmt("(rn,-7pf18.3)", -643.125, "            -0.000")
 174     call checkfmt("(rn,-6pf18.3)", -643.125, "            -0.001")
 175     call checkfmt("(rn,-5pf18.3)", -643.125, "            -0.006")
 176     call checkfmt("(rn,-4pf18.3)", -643.125, "            -0.064")
 177     call checkfmt("(rn,-3pf18.3)", -643.125, "            -0.643")
 178     call checkfmt("(rn,-2pf18.3)", -643.125, "            -6.431")
 179     call checkfmt("(rn,-1pf18.3)", -643.125, "           -64.312")
 180     call checkfmt("(rn, 0pf18.3)", -643.125, "          -643.125")
 181
 182     call checkfmt("(rp,-8pf18.3)", -643.125, "            -0.000")
 183     call checkfmt("(rp,-7pf18.3)", -643.125, "            -0.000")
 184     call checkfmt("(rp,-6pf18.3)", -643.125, "            -0.001")
 185     call checkfmt("(rp,-5pf18.3)", -643.125, "            -0.006")
 186     call checkfmt("(rp,-4pf18.3)", -643.125, "            -0.064")
 187     call checkfmt("(rp,-3pf18.3)", -643.125, "            -0.643")
 188     call checkfmt("(rp,-2pf18.3)", -643.125, "            -6.431")
 189     call checkfmt("(rp,-1pf18.3)", -643.125, "           -64.312")
 190     call checkfmt("(rp, 0pf18.3)", -643.125, "          -643.125")
 191
 192     ! print *, n_tst, n_cnt, n_skip
 193     if (n_cnt /= 0) STOP 1
 194     if (all(.not. l_skip)) print *, "All kinds rounded to nearest"
 195
 196 contains
 197     subroutine checkfmt(fmt, x, cmp)
 198         implicit none
 199         integer :: i
 200         character(len=*), intent(in) :: fmt
 201         real, intent(in) :: x
 202         character(len=*), intent(in) :: cmp
 203         do i=1,size(real_kinds)
 204           if (i == 1) then
 205             write(s, fmt) real(x,kind=j(1))
 206           else if (i == 2) then
 207             write(s, fmt) real(x,kind=j(2))
 208           else if (i == 3) then
 209             write(s, fmt) real(x,kind=j(3))
 210           else if (i == 4) then
 211             write(s, fmt) real(x,kind=j(4))
 212           end if
 213           n_tst = n_tst + 1
 214           if (s /= cmp) then
 215             if (l_skip(i)) then
 216               n_skip = n_skip + 1
 217             else
 218               print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp
 219               n_cnt = n_cnt + 1
 220             end if
 221           end if
 222         end do
 223
 224     end subroutine
 225 end program
 226 ! { dg-output "All kinds rounded to nearest" { xfail { hppa*-*-hpux* } } }