[multiple changes]

2016-03-30  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	    Dominique d'Humieres  <dominiq@lps.ens.fr>

	PR libgfortran/70235
	* io/write_float.def: Fix PF format for negative values of the scale
	factor.

2016-03-30  Dominique d'Humieres  <dominiq@lps.ens.fr>
	    Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	* gfortran.dg/fmt_pf.f90: New test.

From-SVN: r234600

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 505e7d78de15260eb764f727e6b0ef7baa563547..8e2bd73417688bb83af9f19591b01f564d144b75 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-03-30  Dominique d'Humieres  <dominiq@lps.ens.fr>
+           Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       * gfortran.dg/fmt_pf.f90: New test.
+
 2016-03-30  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
        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 (file)
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 6a742b505971999f59606a9bdf036e8612b43b85..688a16e8d8ba9516d1a9d4ddcd9ef4fe808f08cd 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2016-03-30  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+           Dominique d'Humieres  <dominiq@lps.ens.fr>
+
+       PR libgfortran/70235
+       * io/write_float.def: Fix PF format for negative values of the scale
+       factor.
+
 2016-03-28  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
 
        * 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 d4270193656dab3839f864b0bbce2ae1005ef710..d32440f6f9bb600ff999aff7fb4989c036108c22 100644 (file)
--- 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