1! RUN: bbc -pft-test -o %t %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: Module test 148module test 149 !! When derived type processing is implemented, remove all instances of: 150 !! - !![disable] 151 !! - COM: 152 !![disable]type :: a_type 153 !![disable] integer :: x 154 !![disable]end type 155 !![disable]type, extends(a_type) :: b_type 156 !![disable] integer :: y 157 !![disable]end type 158 interface 159 subroutine ss(aa) 160 ! CHECK: CompilerDirective 161 !DIR$ IGNORE_TKR aa 162 integer :: aa 163 end subroutine ss 164 end interface 165contains 166 ! CHECK: Function foo 167 function foo(x) 168 real x(..) 169 integer :: foo 170 ! CHECK: <<SelectRankConstruct!>> 171 ! CHECK: SelectRankStmt 172 select rank(x) 173 ! CHECK: SelectRankCaseStmt 174 rank (0) 175 ! CHECK: AssignmentStmt 176 foo = 0 177 ! CHECK: SelectRankCaseStmt 178 rank (*) 179 ! CHECK: AssignmentStmt 180 foo = -1 181 ! CHECK: SelectRankCaseStmt 182 rank (1) 183 ! CHECK: AssignmentStmt 184 foo = 1 185 ! CHECK: SelectRankCaseStmt 186 rank default 187 ! CHECK: AssignmentStmt 188 foo = 2 189 ! CHECK: EndSelectStmt 190 end select 191 ! CHECK: <<End SelectRankConstruct!>> 192 end function 193 194 ! CHECK: Function bar 195 function bar(x) 196 class(*) :: x 197 ! CHECK: <<SelectTypeConstruct!>> 198 ! CHECK: SelectTypeStmt 199 select type(x) 200 ! CHECK: TypeGuardStmt 201 type is (integer) 202 ! CHECK: AssignmentStmt 203 bar = 0 204 !![disable]! COM: CHECK: TypeGuardStmt 205 !![disable]class is (a_type) 206 !![disable] ! COM: CHECK: AssignmentStmt 207 !![disable] bar = 1 208 !![disable] ! COM: CHECK: ReturnStmt 209 !![disable] return 210 ! CHECK: TypeGuardStmt 211 class default 212 ! CHECK: AssignmentStmt 213 bar = -1 214 ! CHECK: EndSelectStmt 215 end select 216 ! CHECK: <<End SelectTypeConstruct!>> 217 end function 218 219 ! CHECK: Subroutine sub 220 subroutine sub(a) 221 real(4):: a 222 ! CHECK: CompilerDirective 223 !DIR$ IGNORE_TKR a 224 end subroutine 225 226 227end module 228 229! CHECK: Subroutine altreturn 230subroutine altreturn(i, j, *, *) 231 ! CHECK: <<IfConstruct!>> 232 if (i>j) then 233 ! CHECK: ReturnStmt 234 return 1 235 else 236 ! CHECK: ReturnStmt 237 return 2 238 end if 239 ! CHECK: <<End IfConstruct!>> 240end subroutine 241 242 243! Remaining TODO 244 245! CHECK: Subroutine iostmts 246subroutine iostmts(filename, a, b, c) 247 character(*) :: filename 248 integer :: length 249 logical :: file_is_opened 250 real, a, b ,c 251 ! CHECK: InquireStmt 252 inquire(file=filename, opened=file_is_opened) 253 ! CHECK: <<IfConstruct>> 254 if (file_is_opened) then 255 ! CHECK: OpenStmt 256 open(10, FILE=filename) 257 end if 258 ! CHECK: <<End IfConstruct>> 259 ! CHECK: ReadStmt 260 read(10, *) length 261 ! CHECK: RewindStmt 262 rewind 10 263 ! CHECK-NOT: NamelistStmt 264 namelist /nlist/ a, b, c 265 ! CHECK: WriteStmt 266 write(10, NML=nlist) 267 ! CHECK: BackspaceStmt 268 backspace(10) 269 ! CHECK: FormatStmt 2701 format (1PE12.4) 271 ! CHECK: WriteStmt 272 write (10, 1) a 273 ! CHECK: EndfileStmt 274 endfile 10 275 ! CHECK: FlushStmt 276 flush 10 277 ! CHECK: WaitStmt 278 wait(10) 279 ! CHECK: CloseStmt 280 close(10) 281end subroutine 282 283 284! CHECK: Subroutine sub2 285subroutine sub2() 286 integer :: i, j, k, l 287 i = 0 2881 j = i 289 ! CHECK: ContinueStmt 2902 continue 291 i = i+1 2923 j = j+1 293! CHECK: ArithmeticIfStmt 294 if (j-i) 3, 4, 5 295 ! CHECK: GotoStmt 2964 goto 6 297 298! FIXME: is name resolution on assigned goto broken/todo ? 299! WILLCHECK: AssignStmt 300!55 assign 6 to label 301! WILLCHECK: AssignedGotoStmt 302!66 go to label (5, 6) 303 304! CHECK: ComputedGotoStmt 305 go to (5, 6), 1 + mod(i, 2) 3065 j = j + 1 3076 i = i + j/2 308 309 ! CHECK: <<DoConstruct!>> 310 do1: do k=1,10 311 ! CHECK: <<DoConstruct!>> 312 do2: do l=5,20 313 ! CHECK: CycleStmt 314 cycle do1 315 ! CHECK: ExitStmt 316 exit do2 317 end do do2 318 ! CHECK: <<End DoConstruct!>> 319 end do do1 320 ! CHECK: <<End DoConstruct!>> 321 322 ! CHECK: PauseStmt 323 pause 7 324 ! CHECK: StopStmt 325 stop 326end subroutine 327 328 329! CHECK: Subroutine sub3 330subroutine sub3() 331 print *, "normal" 332 ! CHECK: EntryStmt 333 entry sub4entry() 334 print *, "test" 335end subroutine 336 337! CHECK: Subroutine sub4 338subroutine sub4() 339 integer :: i 340 print*, "test" 341 data i /1/ 342end subroutine 343