summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/fmt_fw_d.f90
blob: 1af3bda55d8848726717fe704b7c3aec9c7f0d2b (plain)
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