gcc/testsuite/gfortran.dg/fmt_g0_6.f08

   1 ! { dg-do run }
   2 ! { dg-options "-ffloat-store" }
   3 ! PR48602 Invalid F conversion of G descriptor for values close to powers of 10
   4 ! Test case provided by Thomas Henlich
   5 program test_g0fr
   6     use iso_fortran_env
   7     implicit none
   8     integer, parameter :: RT = REAL64
   9
  10     call check_all(0.0_RT, 15, 2, 0)
  11     call check_all(0.991_RT, 15, 2, 0)
  12     call check_all(0.995_RT, 15, 2, 0)
  13     call check_all(0.996_RT, 15, 2, 0)
  14     call check_all(0.999_RT, 15, 2, 0)
  15 contains
  16     subroutine check_all(val, w, d, e)
  17         real(kind=RT), intent(in) :: val
  18         integer, intent(in) :: w
  19         integer, intent(in) :: d
  20         integer, intent(in) :: e
  21
  22         call check_f_fmt(val, 'C', w, d, e)
  23         call check_f_fmt(val, 'U', w, d, e)
  24         call check_f_fmt(val, 'D', w, d, e)
  25     end subroutine check_all
  26
  27     subroutine check_f_fmt(val, roundmode, w, d, e)
  28         real(kind=RT), intent(in) :: val
  29         character, intent(in) :: roundmode
  30         integer, intent(in) :: w
  31         integer, intent(in) :: d
  32         integer, intent(in) :: e
  33         character(len=80) :: fmt_f, fmt_g
  34         character(len=80) :: s_f, s_g
  35         real(kind=RT) :: mag, lower, upper
  36         real(kind=RT) :: r
  37         integer :: n, dec
  38
  39         mag = abs(val)
  40         if (e == 0) then
  41             n = 4
  42         else
  43             n = e + 2
  44         end if
  45         select case (roundmode)
  46             case('U')
  47                 r = 1.0_RT
  48             case('D')
  49                 r = 0.0_RT
  50             case('C')
  51                 r = 0.5_RT
  52         end select
  53
  54         if (mag == 0) then
  55             write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n
  56         else
  57             do dec = d, 0, -1
  58                 lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)
  59                 upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)
  60                 if (lower <= mag .and. mag < upper) then
  61                     write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n
  62                     exit
  63                 end if
  64             end do
  65         end if
  66         if (len_trim(fmt_f) == 0) then
  67             ! e editing
  68             return
  69         end if
  70         if (e == 0) then
  71             write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d
  72         else
  73             write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e
  74         end if
  75         write(s_g, "('''', " // trim(fmt_g) // ",'''')") val
  76         write(s_f, "('''', " // trim(fmt_f) // ",'''')") val
  77         if (s_g /= s_f) STOP 1
  78         !if (s_g /= s_f) then
  79             !print "(a,g0,a,g0)", "lower=", lower, " upper=", upper
  80            ! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val
  81         !end if
  82     end subroutine check_f_fmt
  83 end program test_g0fr