flang/test/Lower/pre-fir-tree02.f90

   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
   7 program 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
  91 22        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)
 145 end
 146
 147 ! CHECK: Module test
 148 module 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
 165 contains
 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
 227 end module
 228
 229 ! CHECK: Subroutine altreturn
 230 subroutine 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!>>
 240 end subroutine
 241
 242
 243 ! Remaining TODO
 244
 245 ! CHECK: Subroutine iostmts
 246 subroutine 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
 270 1 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)
 281 end subroutine
 282
 283
 284 ! CHECK: Subroutine sub2
 285 subroutine sub2()
 286   integer :: i, j, k, l
 287   i = 0
 288 1 j = i
 289   ! CHECK: ContinueStmt
 290 2 continue
 291   i = i+1
 292 3 j = j+1
 293 ! CHECK: ArithmeticIfStmt
 294   if (j-i) 3, 4, 5
 295   ! CHECK: GotoStmt
 296 4  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)
 306 5 j = j + 1
 307 6 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
 326 end subroutine
 327
 328
 329 ! CHECK: Subroutine sub3
 330 subroutine sub3()
 331  print *, "normal"
 332   ! CHECK: EntryStmt
 333  entry sub4entry()
 334  print *, "test"
 335 end subroutine
 336
 337 ! CHECK: Subroutine sub4
 338 subroutine sub4()
 339   integer :: i
 340   print*, "test"
 341   data i /1/
 342 end subroutine