summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/namelist_19.f90
blob: 4821033ecd7cc43d195327345a9ee6a8253cc73a (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
132
133
134
135
136
137
!{ dg-do run }
!{ dg-options "-std=legacy" }
!
! Test namelist error trapping.
! provided by Paul Thomas - pault@gcc.gnu.org

program namelist_19
  character*80 wrong, right
  
! "=" before any object name
  wrong = "&z = i = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! &* instead of &end for termination 
  wrong = "&z i = 1,2 &xxx"
  right = "&z i = 1,2 &end"
  call test_err(wrong, right)
  
! bad data 
  wrong = "&z i = 1,q /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! object name not matched 
  wrong = "&z j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! derived type component for intrinsic type
  wrong = "&z i%j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! step other than 1 for substring qualifier
  wrong = "&z ch(1:2:2) = 'a'/"
  right = "&z ch(1:2) = 'ab' /"
  call test_err(wrong, right)

! qualifier for scalar 
  wrong = "&z k(2) = 1 /"
  right = "&z k    = 1 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! repeat count too large 
  wrong = "&z i = 3*2 /"
  right = "&z i = 2*2 /"
  call test_err(wrong, right)

! too much data 
  wrong = "&z i = 1 2 3 /"
  right = "&z i = 1 2 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! bad number of index fields
  wrong = "&z i(1,2) = 1 /"
  right = "&z i(1)   = 1 /"
  call test_err(wrong, right)

! bad character in index field 
  wrong = "&z i(x) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i( ) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1::)   = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1:2:)  = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(10) = 1 /"
  right = "&z i(1)  = 1 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(0:1) = 1 /"
  right = "&z i(1:1) = 1 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(1:2:-1) = 1 2 /"
  right = "&z i(1:2: 1) = 1 2 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(2:1: 1) = 1 2 /"
  right = "&z i(2:1:-1) = 1 2 /"
  call test_err(wrong, right)

contains
  subroutine test_err(wrong, right)
    character*80 wrong, right
    integer            :: i(2) = (/0, 0/)
    integer            :: k =0
    character*2        :: ch = "  "
    namelist /z/ i, k, ch

! Check that wrong namelist input gives an error

    open (10, status = "scratch")
    write (10, '(A)') wrong
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier == 0) call abort ()

! Check that right namelist input gives no error

    open (10, status = "scratch")
    write (10, '(A)') right
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier /= 0) call abort ()
  end subroutine test_err
  
end program namelist_19