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

gcc/testsuite/ChangeLog

+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.

gcc/testsuite/gfortran.dg/fmt_fw_d.f90

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