http://gcc.gnu.org/bugzilla/show_bug.cgi?id=60128
--- Comment #53 from Dominique d'Humieres <dominiq at lps dot ens.fr> ---
Dave, Rainer,
Could you test the following code?
[karma] f90/bug% cat fmt_en_1.f90
! { dg-do run }
! PR60128 Invalid outputs with EN descriptors
! Test case provided by Walt Brainerd.
program pr60128
use ISO_FORTRAN_ENV
implicit none
integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]]
logical :: l_skip(4) = .false.
integer :: i
integer :: n_tst = 0, n_cnt = 0
character(len=20) :: s
open (unit = 10, file = 'fmt_en.res')
! Check that the default rounding mode is to nearest and to even on tie.
do i=1,size(real_kinds)
if (i == 1) then
write(s, '(2(1PE9.1))') real(9950.0,kind=j(1)), &
real(9750.0,kind=j(1))
else if (i == 2) then
write(s, '(2(1PE9.1))') real(9950.0,kind=j(2)), &
real(9750.0,kind=j(2))
else if (i == 3) then
write(s, '(2(1PE9.1))') real(9950.0,kind=j(3)), &
real(9750.0,kind=j(3))
else if (i == 4) then
write(s, '(2(1PE9.1))') real(9950.0,kind=j(4)), &
real(9750.0,kind=j(4))
end if
if (s /= ' 1.0E+04 9.8E+03') then
l_skip(i) = .true.
print "('Unsupported rounding for real(',i0,')')", j(i)
write (10, "('Unsupported rounding for real(',i0,')')") j(i)
end if
end do
call checkfmt("(en15.0)", 9500.0, " 10.E+03")
call checkfmt("(en15.1)", 9950.0, " 10.0E+03")
call checkfmt("(en15.0)", -9500.0, " -10.E+03")
call checkfmt("(en15.1)", -9950.0, " -10.0E+03")
call checkfmt("(en15.1)", 987350., " 987.4E+03")
call checkfmt("(en15.2)", 98765., " 98.76E+03")
call checkfmt("(en15.1)", -987350., " -987.4E+03")
call checkfmt("(en15.2)", -98765., " -98.76E+03")
print *, n_tst, n_cnt
if (n_cnt /= 0) call abort
contains
subroutine checkfmt(fmt, x, cmp)
implicit none
integer :: i
character(len=*), intent(in) :: fmt
real, intent(in) :: x
character(len=*), intent(in) :: cmp
do i=1,size(real_kinds)
if (l_skip(i)) cycle
if (i == 1) then
write(s, fmt) real(x,kind=j(1))
else if (i == 2) then
write(s, fmt) real(x,kind=j(2))
else if (i == 3) then
write(s, fmt) real(x,kind=j(3))
else if (i == 4) then
write(s, fmt) real(x,kind=j(4))
end if
n_tst = n_tst + 1
if (s /= cmp) then
print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp
n_cnt = n_cnt + 1
end if
end do
end subroutine
end program
! { dg-final { scan-file-not fmt_en.res "Unsupported rounding" { xfail {
i?86-*-solaris2.9* hppa*-*-hpux11* } } } }
! { dg-final { cleanup-saved-temps } }
