343 lines · plain
1! RUN: bbc -pft-test -o %t %s | FileCheck %s2 3! Test Pre-FIR Tree captures all the intended nodes from the parse-tree4! Coarray and OpenMP related nodes are tested in other files.5 6! CHECK: Program TEST_PROG7program test_prog8 ! Check specification part is not part of the tree.9 interface10 subroutine incr(i)11 integer, intent(inout) :: i12 end subroutine13 end interface14 integer :: i, j, k15 real, allocatable, target :: x(:)16 real :: y(100)17 ! CHECK-NOT: node18 ! CHECK: <<DoConstruct>>19 ! CHECK: NonLabelDoStmt20 do i=1,521 ! CHECK: PrintStmt22 print *, "hey"23 ! CHECK: <<DoConstruct>>24 ! CHECK: NonLabelDoStmt25 do j=1,526 ! CHECK: PrintStmt27 print *, "hello", i, j28 ! CHECK: EndDoStmt29 end do30 ! CHECK: <<End DoConstruct>>31 ! CHECK: EndDoStmt32 end do33 ! CHECK: <<End DoConstruct>>34 35 ! CHECK: <<AssociateConstruct>>36 ! CHECK: AssociateStmt37 associate (k => i + j)38 ! CHECK: AllocateStmt39 allocate(x(k))40 ! CHECK: EndAssociateStmt41 end associate42 ! CHECK: <<End AssociateConstruct>>43 44 ! CHECK: <<BlockConstruct!>>45 ! CHECK: BlockStmt46 block47 integer :: k, l48 real, pointer :: p(:)49 ! CHECK: PointerAssignmentStmt50 p => x51 ! CHECK: AssignmentStmt52 k = size(p)53 ! CHECK: AssignmentStmt54 l = 155 ! CHECK: <<CaseConstruct!>>56 ! CHECK: SelectCaseStmt57 select case (k)58 ! CHECK: CaseStmt59 case (:0)60 ! CHECK: NullifyStmt61 nullify(p)62 ! CHECK: CaseStmt63 case (1)64 ! CHECK: <<IfConstruct>>65 ! CHECK: IfThenStmt66 if (p(1)>0.) then67 ! CHECK: PrintStmt68 print *, "+"69 ! CHECK: ElseIfStmt70 else if (p(1)==0.) then71 ! CHECK: PrintStmt72 print *, "0."73 ! CHECK: ElseStmt74 else75 ! CHECK: PrintStmt76 print *, "-"77 ! CHECK: EndIfStmt78 end if79 ! CHECK: <<End IfConstruct>>80 ! CHECK: CaseStmt81 case (2:10)82 ! CHECK: CaseStmt83 case default84 ! Note: label-do-loop are canonicalized into do constructs85 ! CHECK: <<DoConstruct!>>86 ! CHECK: NonLabelDoStmt87 do 22 while(l<=k)88 ! CHECK: IfStmt89 if (p(l)<0.) p(l)=cos(p(l))90 ! CHECK: CallStmt9122 call incr(l)92 ! CHECK: EndDoStmt93 ! CHECK: <<End DoConstruct!>>94 ! CHECK: CaseStmt95 case (100:)96 ! CHECK: EndSelectStmt97 end select98 ! CHECK: <<End CaseConstruct!>>99 ! CHECK: EndBlockStmt100 end block101 ! CHECK: <<End BlockConstruct!>>102 103 ! CHECK-NOT: WhereConstruct104 ! CHECK: WhereStmt105 where (x > 1.) x = x/2.106 107 ! CHECK: <<WhereConstruct>>108 ! CHECK: WhereConstructStmt109 where (x == 0.)110 ! CHECK: AssignmentStmt111 x = 0.01112 ! CHECK: MaskedElsewhereStmt113 elsewhere (x < 0.5)114 ! CHECK: AssignmentStmt115 x = x*2.116 ! CHECK: <<WhereConstruct>>117 where (y > 0.4)118 ! CHECK: AssignmentStmt119 y = y/2.120 end where121 ! CHECK: <<End WhereConstruct>>122 ! CHECK: ElsewhereStmt123 elsewhere124 ! CHECK: AssignmentStmt125 x = x + 1.126 ! CHECK: EndWhereStmt127 end where128 ! CHECK: <<End WhereConstruct>>129 130 ! CHECK-NOT: ForAllConstruct131 ! CHECK: ForallStmt132 forall (i = 1:5) x(i) = y(i)133 134 ! CHECK: <<ForallConstruct>>135 ! CHECK: ForallConstructStmt136 forall (i = 1:5)137 ! CHECK: AssignmentStmt138 x(i) = x(i) + y(10*i)139 ! CHECK: EndForallStmt140 end forall141 ! CHECK: <<End ForallConstruct>>142 143 ! CHECK: DeallocateStmt144 deallocate(x)145end146 147! CHECK: Module test148module test149 !! When derived type processing is implemented, remove all instances of:150 !! - !![disable]151 !! - COM:152 !![disable]type :: a_type153 !![disable] integer :: x154 !![disable]end type155 !![disable]type, extends(a_type) :: b_type156 !![disable] integer :: y157 !![disable]end type158 interface159 subroutine ss(aa)160 ! CHECK: CompilerDirective161 !DIR$ IGNORE_TKR aa162 integer :: aa163 end subroutine ss164 end interface165contains166 ! CHECK: Function foo167 function foo(x)168 real x(..)169 integer :: foo170 ! CHECK: <<SelectRankConstruct!>>171 ! CHECK: SelectRankStmt172 select rank(x)173 ! CHECK: SelectRankCaseStmt174 rank (0)175 ! CHECK: AssignmentStmt176 foo = 0177 ! CHECK: SelectRankCaseStmt178 rank (*)179 ! CHECK: AssignmentStmt180 foo = -1181 ! CHECK: SelectRankCaseStmt182 rank (1)183 ! CHECK: AssignmentStmt184 foo = 1185 ! CHECK: SelectRankCaseStmt186 rank default187 ! CHECK: AssignmentStmt188 foo = 2189 ! CHECK: EndSelectStmt190 end select191 ! CHECK: <<End SelectRankConstruct!>>192 end function193 194 ! CHECK: Function bar195 function bar(x)196 class(*) :: x197 ! CHECK: <<SelectTypeConstruct!>>198 ! CHECK: SelectTypeStmt199 select type(x)200 ! CHECK: TypeGuardStmt201 type is (integer)202 ! CHECK: AssignmentStmt203 bar = 0204 !![disable]! COM: CHECK: TypeGuardStmt205 !![disable]class is (a_type)206 !![disable] ! COM: CHECK: AssignmentStmt207 !![disable] bar = 1208 !![disable] ! COM: CHECK: ReturnStmt209 !![disable] return210 ! CHECK: TypeGuardStmt211 class default212 ! CHECK: AssignmentStmt213 bar = -1214 ! CHECK: EndSelectStmt215 end select216 ! CHECK: <<End SelectTypeConstruct!>>217 end function218 219 ! CHECK: Subroutine sub220 subroutine sub(a)221 real(4):: a222 ! CHECK: CompilerDirective223 !DIR$ IGNORE_TKR a224 end subroutine225 226 227end module228 229! CHECK: Subroutine altreturn230subroutine altreturn(i, j, *, *)231 ! CHECK: <<IfConstruct!>>232 if (i>j) then233 ! CHECK: ReturnStmt234 return 1235 else236 ! CHECK: ReturnStmt237 return 2238 end if239 ! CHECK: <<End IfConstruct!>>240end subroutine241 242 243! Remaining TODO244 245! CHECK: Subroutine iostmts246subroutine iostmts(filename, a, b, c)247 character(*) :: filename248 integer :: length249 logical :: file_is_opened250 real, a, b ,c251 ! CHECK: InquireStmt252 inquire(file=filename, opened=file_is_opened)253 ! CHECK: <<IfConstruct>>254 if (file_is_opened) then255 ! CHECK: OpenStmt256 open(10, FILE=filename)257 end if258 ! CHECK: <<End IfConstruct>>259 ! CHECK: ReadStmt260 read(10, *) length261 ! CHECK: RewindStmt262 rewind 10263 ! CHECK-NOT: NamelistStmt264 namelist /nlist/ a, b, c265 ! CHECK: WriteStmt266 write(10, NML=nlist)267 ! CHECK: BackspaceStmt268 backspace(10)269 ! CHECK: FormatStmt2701 format (1PE12.4)271 ! CHECK: WriteStmt272 write (10, 1) a273 ! CHECK: EndfileStmt274 endfile 10275 ! CHECK: FlushStmt276 flush 10277 ! CHECK: WaitStmt278 wait(10)279 ! CHECK: CloseStmt280 close(10)281end subroutine282 283 284! CHECK: Subroutine sub2285subroutine sub2()286 integer :: i, j, k, l287 i = 02881 j = i289 ! CHECK: ContinueStmt2902 continue291 i = i+12923 j = j+1293! CHECK: ArithmeticIfStmt294 if (j-i) 3, 4, 5295 ! CHECK: GotoStmt2964 goto 6297 298! FIXME: is name resolution on assigned goto broken/todo ?299! WILLCHECK: AssignStmt300!55 assign 6 to label301! WILLCHECK: AssignedGotoStmt302!66 go to label (5, 6)303 304! CHECK: ComputedGotoStmt305 go to (5, 6), 1 + mod(i, 2)3065 j = j + 13076 i = i + j/2308 309 ! CHECK: <<DoConstruct!>>310 do1: do k=1,10311 ! CHECK: <<DoConstruct!>>312 do2: do l=5,20313 ! CHECK: CycleStmt314 cycle do1315 ! CHECK: ExitStmt316 exit do2317 end do do2318 ! CHECK: <<End DoConstruct!>>319 end do do1320 ! CHECK: <<End DoConstruct!>>321 322 ! CHECK: PauseStmt323 pause 7324 ! CHECK: StopStmt325 stop326end subroutine327 328 329! CHECK: Subroutine sub3330subroutine sub3()331 print *, "normal"332 ! CHECK: EntryStmt333 entry sub4entry()334 print *, "test"335end subroutine336 337! CHECK: Subroutine sub4338subroutine sub4()339 integer :: i340 print*, "test"341 data i /1/342end subroutine343