re PR libfortran/47567 (Wrong output for small absolute values with F editing)

2011-02-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/47567
	* gfortran.dg/fmt_fw_d.f90: New test.

From-SVN: r170586

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fc2ad4fd02c468a98a129dcd92a249bee99c8107..984f0cfd23d164f149a9c5e8621a3d6545b4dfea 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-02-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR libgfortran/47567
+       * gfortran.dg/fmt_fw_d.f90: New test.
+
 2011-02-28  Jason Merrill  <jason@redhat.com>
 
        * g++.dg/inherit/covariant18.C: New.

diff --git a/gcc/testsuite/gfortran.dg/fmt_fw_d.f90 b/gcc/testsuite/gfortran.dg/fmt_fw_d.f90
new file mode 100644 (file)
index 0000000..6d4c203
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/fmt_fw_d.f90
@@ -0,0 +1,130 @@
+! { dg-do run }\r
+! PR47567 Wrong output for small absolute values with F editing\r
+! Test case provided by Thomas Henlich \r
+call verify_fmt(1.2)\r
+call verify_fmt(-0.1)\r
+call verify_fmt(1e-7)\r
+call verify_fmt(1e-6)\r
+call verify_fmt(1e-5)\r
+call verify_fmt(1e-4)\r
+call verify_fmt(1e-3)\r
+call verify_fmt(1e-2)\r
+call verify_fmt(-1e-7)\r
+call verify_fmt(-1e-6)\r
+call verify_fmt(-1e-5)\r
+call verify_fmt(-1e-4)\r
+call verify_fmt(-1e-3)\r
+call verify_fmt(-1e-2)\r
+call verify_fmt(tiny(0.0))\r
+call verify_fmt(-tiny(0.0))\r
+call verify_fmt(0.0)\r
+call verify_fmt(-0.0)\r
+call verify_fmt(100.0)\r
+call verify_fmt(.12345)\r
+call verify_fmt(1.2345)\r
+call verify_fmt(12.345)\r
+call verify_fmt(123.45)\r
+call verify_fmt(1234.5)\r
+call verify_fmt(12345.6)\r
+call verify_fmt(123456.7)\r
+call verify_fmt(99.999)\r
+call verify_fmt(-100.0)\r
+call verify_fmt(-99.999)\r
+end\r
+\r
+! loop through values for w, d\r
+subroutine verify_fmt(x)\r
+    real, intent(in) :: x\r
+    integer :: w, d\r
+    character(len=80) :: str, str0\r
+    integer :: len, len0\r
+    character(len=80) :: fmt_w_d\r
+    logical :: result, have_num, verify_fmt_w_d\r
+    \r
+    do d = 0, 10\r
+        have_num = .false.\r
+        do w = 1, 20\r
+            str = fmt_w_d(x, w, d)\r
+            len = len_trim(str)\r
+            \r
+            result = verify_fmt_w_d(x, str, len, w, d)\r
+            if (.not. have_num .and. result) then\r
+                have_num = .true.\r
+                str0 = fmt_w_d(x, 0, d)\r
+                len0 = len_trim(str0)\r
+                if (len /= len0) then\r
+                    call errormsg(x, str0, len0, 0, d, "selected width is wrong")\r
+                else\r
+                    if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong")\r
+                end if\r
+            end if\r
+        end do\r
+    end do\r
+\r
+end subroutine\r
+\r
+! checks for standard-compliance, returns .true. if field contains number, .false. on overflow\r
+function verify_fmt_w_d(x, str, len, w, d)\r
+    real, intent(in) :: x\r
+    character(len=80), intent(in) :: str\r
+    integer, intent(in) :: len\r
+    integer, intent(in) :: w, d\r
+    logical :: verify_fmt_w_d\r
+    integer :: pos\r
+    character :: decimal_sep = "."\r
+\r
+    verify_fmt_w_d = .false.\r
+    \r
+    ! check if string is all asterisks\r
+    pos = verify(str(:len), "*")\r
+    if (pos == 0) return\r
+    \r
+    ! check if string contains a digit\r
+    pos = scan(str(:len), "0123456789")\r
+    if (pos == 0) call errormsg(x, str, len, w, d, "no digits")\r
+\r
+    ! contains decimal separator?\r
+    pos = index(str(:len), decimal_sep)\r
+    if (pos == 0) call errormsg(x, str, len, w, d, "no decimal separator")\r
+    \r
+    ! negative and starts with minus?\r
+    if (sign(1., x) < 0.) then\r
+        pos = verify(str, " ")\r
+        if (pos == 0) call errormsg(x, str, len, w, d, "only spaces")\r
+        if (str(pos:pos) /= "-") call errormsg(x, str, len, w, d, "no minus sign")\r
+    end if\r
+    \r
+    verify_fmt_w_d = .true.\r
+end function\r
+\r
+function fmt_w_d(x, w, d)\r
+    real, intent(in) :: x\r
+    integer, intent(in) :: w, d\r
+    character(len=*) :: fmt_w_d\r
+    character(len=10) :: fmt, make_fmt\r
+    \r
+    fmt = make_fmt(w, d)\r
+    write (fmt_w_d, fmt) x\r
+end function\r
+\r
+function make_fmt(w, d)\r
+    integer, intent(in) :: w, d\r
+    character(len=10) :: make_fmt\r
+    \r
+    write (make_fmt,'("(f",i0,".",i0,")")') w, d\r
+end function\r
+\r
+subroutine errormsg(x, str, len, w, d, reason)\r
+    real, intent(in) :: x\r
+    character(len=80), intent(in) :: str\r
+    integer, intent(in) :: len, w, d\r
+    character(len=*), intent(in) :: reason\r
+    integer :: fmt_len\r
+    character(len=10) :: fmt, make_fmt\r
+    \r
+    fmt = make_fmt(w, d)\r
+    fmt_len = len_trim(fmt)\r
+    \r
+    !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason\r
+    call abort\r
+end subroutine\r