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