gcc/testsuite/gfortran.dg/fmt_fw_d.f90

   1 ! { dg-do run }
   2 ! PR47567 Wrong output for small absolute values with F editing
   3 ! Test case provided by Thomas Henlich
   4 call verify_fmt(1.2)
   5 call verify_fmt(-0.1)
   6 call verify_fmt(1e-7)
   7 call verify_fmt(1e-6)
   8 call verify_fmt(1e-5)
   9 call verify_fmt(1e-4)
  10 call verify_fmt(1e-3)
  11 call verify_fmt(1e-2)
  12 call verify_fmt(-1e-7)
  13 call verify_fmt(-1e-6)
  14 call verify_fmt(-1e-5)
  15 call verify_fmt(-1e-4)
  16 call verify_fmt(-1e-3)
  17 call verify_fmt(-1e-2)
  18 call verify_fmt(tiny(0.0))
  19 call verify_fmt(-tiny(0.0))
  20 call verify_fmt(0.0)
  21 call verify_fmt(-0.0)
  22 call verify_fmt(100.0)
  23 call verify_fmt(.12345)
  24 call verify_fmt(1.2345)
  25 call verify_fmt(12.345)
  26 call verify_fmt(123.45)
  27 call verify_fmt(1234.5)
  28 call verify_fmt(12345.6)
  29 call verify_fmt(123456.7)
  30 call verify_fmt(99.999)
  31 call verify_fmt(-100.0)
  32 call verify_fmt(-99.999)
  33 end
  34
  35 ! loop through values for w, d
  36 subroutine verify_fmt(x)
  37     real, intent(in) :: x
  38     integer :: w, d
  39     character(len=80) :: str, str0
  40     integer :: len, len0
  41     character(len=80) :: fmt_w_d
  42     logical :: result, have_num, verify_fmt_w_d
  43
  44     do d = 0, 10
  45         have_num = .false.
  46         do w = 1, 20
  47             str = fmt_w_d(x, w, d)
  48             len = len_trim(str)
  49
  50             result = verify_fmt_w_d(x, str, len, w, d)
  51             if (.not. have_num .and. result) then
  52                 have_num = .true.
  53                 str0 = fmt_w_d(x, 0, d)
  54                 len0 = len_trim(str0)
  55                 if (len /= len0) then
  56                     call errormsg(x, str0, len0, 0, d, "selected width is wrong")
  57                 else
  58                     if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong")
  59                 end if
  60             end if
  61         end do
  62     end do
  63
  64 end subroutine
  65
  66 ! checks for standard-compliance, returns .true. if field contains number, .false. on overflow
  67 function verify_fmt_w_d(x, str, len, w, d)
  68     real, intent(in) :: x
  69     character(len=80), intent(in) :: str
  70     integer, intent(in) :: len
  71     integer, intent(in) :: w, d
  72     logical :: verify_fmt_w_d
  73     integer :: pos
  74     character :: decimal_sep = "."
  75
  76     verify_fmt_w_d = .false.
  77
  78     ! check if string is all asterisks
  79     pos = verify(str(:len), "*")
  80     if (pos == 0) return
  81
  82     ! check if string contains a digit
  83     pos = scan(str(:len), "0123456789")
  84     if (pos == 0) call errormsg(x, str, len, w, d, "no digits")
  85
  86     ! contains decimal separator?
  87     pos = index(str(:len), decimal_sep)
  88     if (pos == 0) call errormsg(x, str, len, w, d, "no decimal separator")
  89
  90     ! negative and starts with minus?
  91     if (sign(1., x) < 0.) then
  92         pos = verify(str, " ")
  93         if (pos == 0) call errormsg(x, str, len, w, d, "only spaces")
  94         if (str(pos:pos) /= "-") call errormsg(x, str, len, w, d, "no minus sign")
  95     end if
  96
  97     verify_fmt_w_d = .true.
  98 end function
  99
 100 function fmt_w_d(x, w, d)
 101     real, intent(in) :: x
 102     integer, intent(in) :: w, d
 103     character(len=*) :: fmt_w_d
 104     character(len=10) :: fmt, make_fmt
 105
 106     fmt = make_fmt(w, d)
 107     write (fmt_w_d, fmt) x
 108 end function
 109
 110 function make_fmt(w, d)
 111     integer, intent(in) :: w, d
 112     character(len=10) :: make_fmt
 113
 114     write (make_fmt,'("(f",i0,".",i0,")")') w, d
 115 end function
 116
 117 subroutine errormsg(x, str, len, w, d, reason)
 118     real, intent(in) :: x
 119     character(len=80), intent(in) :: str
 120     integer, intent(in) :: len, w, d
 121     character(len=*), intent(in) :: reason
 122     integer :: fmt_len
 123     character(len=10) :: fmt, make_fmt
 124
 125     fmt = make_fmt(w, d)
 126     fmt_len = len_trim(fmt)
 127
 128     !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason
 129     call abort
 130 end subroutine