1! RUN: %f18 -fdebug-pre-fir-tree -fparse-only %s | FileCheck %s
2
3! Test Pre-FIR Tree captures all the intended nodes from the parse-tree
4! Coarray and OpenMP related nodes are tested in other files.
5
6! CHECK: Program test_prog
7program test_prog
8  ! Check specification part is not part of the tree.
9  interface
10    subroutine incr(i)
11      integer, intent(inout) :: i
12    end subroutine
13  end interface
14  integer :: i, j, k
15  real, allocatable, target :: x(:)
16  real :: y(100)
17  ! CHECK-NOT: node
18  ! CHECK: <<DoConstruct>>
19  ! CHECK: NonLabelDoStmt
20  do i=1,5
21    ! CHECK: PrintStmt
22    print *, "hey"
23    ! CHECK: <<DoConstruct>>
24    ! CHECK: NonLabelDoStmt
25    do j=1,5
26      ! CHECK: PrintStmt
27      print *, "hello", i, j
28    ! CHECK: EndDoStmt
29    end do
30    ! CHECK: <<End DoConstruct>>
31  ! CHECK: EndDoStmt
32  end do
33  ! CHECK: <<End DoConstruct>>
34
35  ! CHECK: <<AssociateConstruct>>
36  ! CHECK: AssociateStmt
37  associate (k => i + j)
38    ! CHECK: AllocateStmt
39    allocate(x(k))
40  ! CHECK: EndAssociateStmt
41  end associate
42  ! CHECK: <<End AssociateConstruct>>
43
44  ! CHECK: <<BlockConstruct!>>
45  ! CHECK: BlockStmt
46  block
47    integer :: k, l
48    real, pointer :: p(:)
49    ! CHECK: PointerAssignmentStmt
50    p => x
51    ! CHECK: AssignmentStmt
52    k = size(p)
53    ! CHECK: AssignmentStmt
54    l = 1
55    ! CHECK: <<CaseConstruct!>>
56    ! CHECK: SelectCaseStmt
57    select case (k)
58      ! CHECK: CaseStmt
59      case (:0)
60        ! CHECK: NullifyStmt
61        nullify(p)
62      ! CHECK: CaseStmt
63      case (1)
64        ! CHECK: <<IfConstruct>>
65        ! CHECK: IfThenStmt
66        if (p(1)>0.) then
67          ! CHECK: PrintStmt
68          print *, "+"
69        ! CHECK: ElseIfStmt
70        else if (p(1)==0.) then
71          ! CHECK: PrintStmt
72          print *, "0."
73        ! CHECK: ElseStmt
74        else
75          ! CHECK: PrintStmt
76          print *, "-"
77        ! CHECK: EndIfStmt
78        end if
79        ! CHECK: <<End IfConstruct>>
80        ! CHECK: CaseStmt
81      case (2:10)
82      ! CHECK: CaseStmt
83      case default
84        ! Note: label-do-loop are canonicalized into do constructs
85        ! CHECK: <<DoConstruct!>>
86        ! CHECK: NonLabelDoStmt
87        do 22 while(l<=k)
88          ! CHECK: IfStmt
89          if (p(l)<0.) p(l)=cos(p(l))
90          ! CHECK: CallStmt
9122        call incr(l)
92        ! CHECK: EndDoStmt
93       ! CHECK: <<End DoConstruct!>>
94      ! CHECK: CaseStmt
95      case (100:)
96    ! CHECK: EndSelectStmt
97    end select
98  ! CHECK: <<End CaseConstruct!>>
99  ! CHECK: EndBlockStmt
100  end block
101  ! CHECK: <<End BlockConstruct!>>
102
103  ! CHECK-NOT: WhereConstruct
104  ! CHECK: WhereStmt
105  where (x > 1.) x = x/2.
106
107  ! CHECK: <<WhereConstruct>>
108  ! CHECK: WhereConstructStmt
109  where (x == 0.)
110    ! CHECK: AssignmentStmt
111    x = 0.01
112  ! CHECK: MaskedElsewhereStmt
113  elsewhere (x < 0.5)
114    ! CHECK: AssignmentStmt
115    x = x*2.
116    ! CHECK: <<WhereConstruct>>
117    where (y > 0.4)
118      ! CHECK: AssignmentStmt
119      y = y/2.
120    end where
121    ! CHECK: <<End WhereConstruct>>
122  ! CHECK: ElsewhereStmt
123  elsewhere
124    ! CHECK: AssignmentStmt
125    x = x + 1.
126  ! CHECK: EndWhereStmt
127  end where
128  ! CHECK: <<End WhereConstruct>>
129
130  ! CHECK-NOT: ForAllConstruct
131  ! CHECK: ForallStmt
132  forall (i = 1:5) x(i) = y(i)
133
134  ! CHECK: <<ForallConstruct>>
135  ! CHECK: ForallConstructStmt
136  forall (i = 1:5)
137    ! CHECK: AssignmentStmt
138    x(i) = x(i) + y(10*i)
139  ! CHECK: EndForallStmt
140  end forall
141  ! CHECK: <<End ForallConstruct>>
142
143  ! CHECK: DeallocateStmt
144  deallocate(x)
145end
146
147! CHECK: ModuleLike
148module test
149  type :: a_type
150    integer :: x
151  end type
152  type, extends(a_type) :: b_type
153    integer :: y
154  end type
155contains
156  ! CHECK: Function foo
157  function foo(x)
158    real x(..)
159    integer :: foo
160    ! CHECK: <<SelectRankConstruct!>>
161    ! CHECK: SelectRankStmt
162    select rank(x)
163      ! CHECK: SelectRankCaseStmt
164      rank (0)
165        ! CHECK: AssignmentStmt
166        foo = 0
167      ! CHECK: SelectRankCaseStmt
168      rank (*)
169        ! CHECK: AssignmentStmt
170        foo = -1
171      ! CHECK: SelectRankCaseStmt
172      rank (1)
173        ! CHECK: AssignmentStmt
174        foo = 1
175      ! CHECK: SelectRankCaseStmt
176      rank default
177        ! CHECK: AssignmentStmt
178        foo = 2
179    ! CHECK: EndSelectStmt
180    end select
181    ! CHECK: <<End SelectRankConstruct!>>
182  end function
183
184  ! CHECK: Function bar
185  function bar(x)
186    class(*) :: x
187    ! CHECK: <<SelectTypeConstruct!>>
188    ! CHECK: SelectTypeStmt
189    select type(x)
190      ! CHECK: TypeGuardStmt
191      type is (integer)
192        ! CHECK: AssignmentStmt
193        bar = 0
194      ! CHECK: TypeGuardStmt
195      class is (a_type)
196        ! CHECK: AssignmentStmt
197        bar = 1
198        ! CHECK: ReturnStmt
199        return
200      ! CHECK: TypeGuardStmt
201      class default
202        ! CHECK: AssignmentStmt
203        bar = -1
204    ! CHECK: EndSelectStmt
205    end select
206    ! CHECK: <<End SelectTypeConstruct!>>
207  end function
208
209  ! CHECK: Subroutine sub
210  subroutine sub(a)
211    real(4):: a
212    ! CompilerDirective
213    ! CHECK: <<CompilerDirective>>
214    !DIR$ IGNORE_TKR a
215  end subroutine
216
217
218end module
219
220! CHECK: Subroutine altreturn
221subroutine altreturn(i, j, *, *)
222  ! CHECK: <<IfConstruct!>>
223  if (i>j) then
224    ! CHECK: ReturnStmt
225    return 1
226  else
227    ! CHECK: ReturnStmt
228    return 2
229  end if
230  ! CHECK: <<End IfConstruct!>>
231end subroutine
232
233
234! Remaining TODO
235
236! CHECK: Subroutine iostmts
237subroutine iostmts(filename, a, b, c)
238  character(*) :: filename
239  integer :: length
240  logical :: file_is_opened
241  real, a, b ,c
242  ! CHECK: InquireStmt
243  inquire(file=filename, opened=file_is_opened)
244  ! CHECK: <<IfConstruct>>
245  if (file_is_opened) then
246    ! CHECK: OpenStmt
247    open(10, FILE=filename)
248  end if
249  ! CHECK: <<End IfConstruct>>
250  ! CHECK: ReadStmt
251  read(10, *) length
252  ! CHECK: RewindStmt
253  rewind 10
254  ! CHECK: NamelistStmt
255  namelist /nlist/ a, b, c
256  ! CHECK: WriteStmt
257  write(10, NML=nlist)
258  ! CHECK: BackspaceStmt
259  backspace(10)
260  ! CHECK: FormatStmt
2611 format (1PE12.4)
262  ! CHECK: WriteStmt
263  write (10, 1) a
264  ! CHECK: EndfileStmt
265  endfile 10
266  ! CHECK: FlushStmt
267  flush 10
268  ! CHECK: WaitStmt
269  wait(10)
270  ! CHECK: CloseStmt
271  close(10)
272end subroutine
273
274
275! CHECK: Subroutine sub2
276subroutine sub2()
277  integer :: i, j, k, l
278  i = 0
2791 j = i
280  ! CHECK: ContinueStmt
2812 continue
282  i = i+1
2833 j = j+1
284! CHECK: ArithmeticIfStmt
285  if (j-i) 3, 4, 5
286  ! CHECK: GotoStmt
2874  goto 6
288
289! FIXME: is name resolution on assigned goto broken/todo ?
290! WILLCHECK: AssignStmt
291!55 assign 6 to label
292! WILLCHECK: AssignedGotoStmt
293!66  go to label (5, 6)
294
295! CHECK: ComputedGotoStmt
296  go to (5, 6), 1 + mod(i, 2)
2975 j = j + 1
2986 i = i + j/2
299
300  ! CHECK: <<DoConstruct!>>
301  do1: do k=1,10
302    ! CHECK: <<DoConstruct!>>
303    do2: do l=5,20
304      ! CHECK: CycleStmt
305      cycle do1
306      ! CHECK: ExitStmt
307      exit do2
308    end do do2
309    ! CHECK: <<End DoConstruct!>>
310  end do do1
311  ! CHECK: <<End DoConstruct!>>
312
313  ! CHECK: PauseStmt
314  pause 7
315  ! CHECK: StopStmt
316  stop
317end subroutine
318
319
320! CHECK: Subroutine sub3
321subroutine sub3()
322 print *, "normal"
323  ! CHECK: EntryStmt
324 entry sub4entry()
325 print *, "test"
326end subroutine
327
328! CHECK: Subroutine sub4
329subroutine sub4()
330  integer :: i
331  print*, "test"
332  ! CHECK: DataStmt
333  data i /1/
334end subroutine
335