2 ! { dg-options "-std=gnu" }
3 ! PR47567 Wrong output for small absolute values with F editing
4 ! Test case provided by Thomas Henlich
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))
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)
36 ! loop through values for w, d
37 subroutine verify_fmt(x)
40 character(len=80) :: str, str0
42 character(len=80) :: fmt_w_d
43 logical :: result, have_num, verify_fmt_w_d
48 str = fmt_w_d(x, w, d)
51 result = verify_fmt_w_d(x, str, len, w, d)
52 if (.not. have_num .and. result) then
54 str0 = fmt_w_d(x, 0, d)
57 call errormsg(x, str0, len0, 0, d, "selected width is wrong")
59 if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong")
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)
70 character(len=80), intent(in) :: str
71 integer, intent(in) :: len
72 integer, intent(in) :: w, d
73 logical :: verify_fmt_w_d
75 character :: decimal_sep = "."
77 verify_fmt_w_d = .false.
79 ! check if string is all asterisks
80 pos = verify(str(:len), "*")
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")
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")
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")
98 verify_fmt_w_d = .true.
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
108 write (fmt_w_d, fmt) x
111 function make_fmt(w, d)
112 integer, intent(in) :: w, d
113 character(len=10) :: make_fmt
115 write (make_fmt,'("(f",i0,".",i0,")")') w, d
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
124 character(len=10) :: fmt, make_fmt
127 fmt_len = len_trim(fmt)
129 !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason