From 91c9586dfef47f2d162fad8eb6e3fd2f88955775 Mon Sep 17 00:00:00 2001 From: dominiq Date: Wed, 30 Mar 2016 20:47:45 +0000 Subject: [PATCH] 2016-03-30 Jerry DeLisle Dominique d'Humieres PR libgfortran/70235 * io/write_float.def: Fix PF format for negative values of the scale factor. 2016-03-30 Dominique d'Humieres Jerry DeLisle * gfortran.dg/fmt_pf.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@234600 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/fmt_pf.f90 | 226 +++++++++++++++++++++++++++++++++++ libgfortran/ChangeLog | 7 ++ libgfortran/io/write_float.def | 26 ++-- 4 files changed, 257 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/fmt_pf.f90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 505e7d7..8e2bd73 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-03-30 Dominique d'Humieres + Jerry DeLisle + + * gfortran.dg/fmt_pf.f90: New test. + 2016-03-30 Rainer Orth Forward-port from 5 branch diff --git a/gcc/testsuite/gfortran.dg/fmt_pf.f90 b/gcc/testsuite/gfortran.dg/fmt_pf.f90 new file mode 100644 index 0000000..6cefa86 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fmt_pf.f90 @@ -0,0 +1,226 @@ +! { dg-do run } +! PR70235 Incorrect output with PF format. +! Test case provided by Antoine Gardeux. +program pr70235 +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, n_skip = 0 + character(len=20) :: s, s1 + +! 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, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= '-9.5 9.5 10. 8.' .or. s1 /= ' 987.4E+03 98.76E+03') then + l_skip(i) = .true. +! print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(-6PF8.3)", 1.0e4, " 0.010") + call checkfmt("(-6PF8.3)", 0.0, " 0.000") + +! Test for the bug in comment 6. + call checkfmt("(-8pf18.3)", 643.125, " 0.000") + call checkfmt("(-7pf18.3)", 643.125, " 0.000") + call checkfmt("(-6pf18.3)", 643.125, " 0.001") + call checkfmt("(-5pf18.3)", 643.125, " 0.006") + call checkfmt("(-4pf18.3)", 643.125, " 0.064") + call checkfmt("(-3pf18.3)", 643.125, " 0.643") + call checkfmt("(-2pf18.3)", 643.125, " 6.431") + call checkfmt("(-1pf18.3)", 643.125, " 64.312") + call checkfmt("( 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(ru,-8pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-7pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-5pf18.3)", 643.125, " 0.007") + call checkfmt("(ru,-4pf18.3)", 643.125, " 0.065") + call checkfmt("(ru,-3pf18.3)", 643.125, " 0.644") + call checkfmt("(ru,-2pf18.3)", 643.125, " 6.432") + call checkfmt("(ru,-1pf18.3)", 643.125, " 64.313") + call checkfmt("(ru, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rd,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-6pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rd,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rd,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rd,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rd,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rd, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rz,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-6pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rz,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rz,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rz,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rz,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rz, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rc,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rc,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rc,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rc,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rc,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rc,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rc,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rc,-1pf18.3)", 643.125, " 64.313") + call checkfmt("(rc, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rn,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rn,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rn,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rn,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rn,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rn,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rn,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rn,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rn, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rp,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rp,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rp,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rp,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rp,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rp,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rp,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rp,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rp, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(-8pf18.3)", -643.125, " -0.000") + call checkfmt("(-7pf18.3)", -643.125, " -0.000") + call checkfmt("(-6pf18.3)", -643.125, " -0.001") + call checkfmt("(-5pf18.3)", -643.125, " -0.006") + call checkfmt("(-4pf18.3)", -643.125, " -0.064") + call checkfmt("(-3pf18.3)", -643.125, " -0.643") + call checkfmt("(-2pf18.3)", -643.125, " -6.431") + call checkfmt("(-1pf18.3)", -643.125, " -64.312") + call checkfmt("( 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(ru,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-6pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(ru,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(ru,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(ru,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(ru,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(ru, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rd,-8pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-7pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-5pf18.3)", -643.125, " -0.007") + call checkfmt("(rd,-4pf18.3)", -643.125, " -0.065") + call checkfmt("(rd,-3pf18.3)", -643.125, " -0.644") + call checkfmt("(rd,-2pf18.3)", -643.125, " -6.432") + call checkfmt("(rd,-1pf18.3)", -643.125, " -64.313") + call checkfmt("(rd, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rz,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-6pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rz,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rz,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rz,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rz,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rz, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rc,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rc,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rc,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rc,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rc,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rc,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rc,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rc,-1pf18.3)", -643.125, " -64.313") + call checkfmt("(rc, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rn,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rn,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rn,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rn,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rn,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rn,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rn,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rn,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rn, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rp,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rp,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rp,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rp,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rp,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rp,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rp,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rp,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rp, 0pf18.3)", -643.125, " -643.125") + + ! print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) call abort + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" + +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 (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 + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 6a742b5..688a16e 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2016-03-30 Jerry DeLisle + Dominique d'Humieres + + PR libgfortran/70235 + * io/write_float.def: Fix PF format for negative values of the scale + factor. + 2016-03-28 Alessandro Fanfarillo * caf/libcaf.h: caf_stop_numeric and caf_stop_str prototype. diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def index d427019..d32440f 100644 --- a/libgfortran/io/write_float.def +++ b/libgfortran/io/write_float.def @@ -184,9 +184,6 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, memmove (digits + nbefore, digits + nbefore + 1, p); digits[nbefore + p] = '.'; nbefore += p; - nafter = d - p; - if (nafter < 0) - nafter = 0; nafter = d; nzero = 0; } @@ -204,12 +201,27 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, { nzero = -(nbefore + p); memmove (digits + 1, digits, nbefore); - digits++; - nafter = d + nbefore; + nafter = d - nzero; + if (nafter == 0 && d > 0) + { + /* This is needed to get the correct rounding. */ + memmove (digits + 1, digits, ndigits - 1); + digits[1] = '0'; + nafter = 1; + nzero = d - 1; + } + else if (nafter < 0) + { + /* Reset digits to 0 in order to get correct rounding + towards infinity. */ + for (i = 0; i < ndigits; i++) + digits[i] = '0'; + digits[ndigits - 1] = '1'; + nafter = d; + nzero = 0; + } nbefore = 0; } - if (nzero > d) - nzero = d; } } else -- 2.7.4