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
5call verify_fmt(1.2)
6call verify_fmt(-0.1)
7call verify_fmt(1e-7)
8call verify_fmt(1e-6)
9call verify_fmt(1e-5)
10call verify_fmt(1e-4)
11call verify_fmt(1e-3)
12call verify_fmt(1e-2)
13call verify_fmt(-1e-7)
14call verify_fmt(-1e-6)
15call verify_fmt(-1e-5)
16call verify_fmt(-1e-4)
17call verify_fmt(-1e-3)
18call verify_fmt(-1e-2)
19call verify_fmt(tiny(0.0))
20call verify_fmt(-tiny(0.0))
21call verify_fmt(0.0)
22call verify_fmt(-0.0)
23call verify_fmt(100.0)
24call verify_fmt(.12345)
25call verify_fmt(1.2345)
26call verify_fmt(12.345)
27call verify_fmt(123.45)
28call verify_fmt(1234.5)
29call verify_fmt(12345.6)
30call verify_fmt(123456.7)
31call verify_fmt(99.999)
32call verify_fmt(-100.0)
33call verify_fmt(-99.999)
34end
35
36! loop through values for w, d
37subroutine 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
65end subroutine
66
67! checks for standard-compliance, returns .true. if field contains number, .false. on overflow
68function 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.
99end function
100
101function 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
109end function
110
111function 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
116end function
117
118subroutine 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
131end subroutine
132