gcc/testsuite/gfortran.dg/fmt_fw_d.f90

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