re PR libfortran/48602 (Invalid F conversion of G descriptor for values close to powers of 10)

2011-04-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/48602
	* gfortran.dg/fmt_g0_6.f08: New test.

From-SVN: r172635

gcc/testsuite/ChangeLog

+2011-04-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libgfortran/48602
+	* gfortran.dg/fmt_g0_6.f08: New test.
+
 2011-04-17  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/cpp0x/sfinae16.C: New.

gcc/testsuite/gfortran.dg/fmt_g0_6.f08

+! { dg-do run }
+! PE48602 Invalid F conversion of G descriptor for values close to powers of 10
+! Test case provided by Thomas Henlich
+program test_g0fr
+    use iso_fortran_env
+    implicit none
+    integer, parameter :: RT = REAL64
+    
+    call check_all(0.0_RT, 15, 2, 0)
+    call check_all(0.991_RT, 15, 2, 0)
+    call check_all(0.995_RT, 15, 2, 0)
+    call check_all(0.996_RT, 15, 2, 0)
+    call check_all(0.999_RT, 15, 2, 0)
+contains
+    subroutine check_all(val, w, d, e)
+        real(kind=RT), intent(in) :: val
+        integer, intent(in) :: w
+        integer, intent(in) :: d
+        integer, intent(in) :: e
+
+        call check_f_fmt(val, 'C', w, d, e)
+        call check_f_fmt(val, 'U', w, d, e)
+        call check_f_fmt(val, 'D', w, d, e)
+    end subroutine check_all
+    
+    subroutine check_f_fmt(val, roundmode, w, d, e)
+        real(kind=RT), intent(in) :: val
+        character, intent(in) :: roundmode
+        integer, intent(in) :: w
+        integer, intent(in) :: d
+        integer, intent(in) :: e
+        character(len=80) :: fmt_f, fmt_g
+        character(len=80) :: s_f, s_g
+        real(kind=RT) :: mag, lower, upper
+        real(kind=RT) :: r
+        integer :: n, dec
+
+        mag = abs(val)
+        if (e == 0) then
+            n = 4
+        else
+            n = e + 2
+        end if
+        select case (roundmode)
+            case('U')
+                r = 1.0_RT
+            case('D')
+                r = 0.0_RT
+            case('C')
+                r = 0.5_RT
+        end select
+
+        if (mag == 0) then
+            write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n
+        else
+            do dec = d, 0, -1
+                lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)
+                upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)
+                if (lower <= mag .and. mag < upper) then
+                    write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n
+                    exit
+                end if
+            end do
+        end if
+        if (len_trim(fmt_f) == 0) then
+            ! e editing
+            return
+        end if
+        if (e == 0) then
+            write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d
+        else
+            write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e
+        end if
+        write(s_g, "('''', " // trim(fmt_g) // ",'''')") val
+        write(s_f, "('''', " // trim(fmt_f) // ",'''')") val
+        if (s_g /= s_f) call abort
+        !if (s_g /= s_f) then
+            !print "(a,g0,a,g0)", "lower=", lower, " upper=", upper
+           ! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val
+        !end if
+    end subroutine check_f_fmt
+end program test_g0fr