! RUN: bbc -pft-test -o %t %s | FileCheck %s

! Test Pre-FIR Tree captures all the intended nodes from the parse-tree
! Coarray and OpenMP related nodes are tested in other files.

! CHECK: Program test_prog
program test_prog
  ! Check specification part is not part of the tree.
  interface
    subroutine incr(i)
      integer, intent(inout) :: i
    end subroutine
  end interface
  integer :: i, j, k
  real, allocatable, target :: x(:)
  real :: y(100)
  ! CHECK-NOT: node
  ! CHECK: <<DoConstruct>>
  ! CHECK: NonLabelDoStmt
  do i=1,5
    ! CHECK: PrintStmt
    print *, "hey"
    ! CHECK: <<DoConstruct>>
    ! CHECK: NonLabelDoStmt
    do j=1,5
      ! CHECK: PrintStmt
      print *, "hello", i, j
    ! CHECK: EndDoStmt
    end do
    ! CHECK: <<End DoConstruct>>
  ! CHECK: EndDoStmt
  end do
  ! CHECK: <<End DoConstruct>>

  ! CHECK: <<AssociateConstruct>>
  ! CHECK: AssociateStmt
  associate (k => i + j)
    ! CHECK: AllocateStmt
    allocate(x(k))
  ! CHECK: EndAssociateStmt
  end associate
  ! CHECK: <<End AssociateConstruct>>

  ! CHECK: <<BlockConstruct!>>
  ! CHECK: BlockStmt
  block
    integer :: k, l
    real, pointer :: p(:)
    ! CHECK: PointerAssignmentStmt
    p => x
    ! CHECK: AssignmentStmt
    k = size(p)
    ! CHECK: AssignmentStmt
    l = 1
    ! CHECK: <<CaseConstruct!>>
    ! CHECK: SelectCaseStmt
    select case (k)
      ! CHECK: CaseStmt
      case (:0)
        ! CHECK: NullifyStmt
        nullify(p)
      ! CHECK: CaseStmt
      case (1)
        ! CHECK: <<IfConstruct>>
        ! CHECK: IfThenStmt
        if (p(1)>0.) then
          ! CHECK: PrintStmt
          print *, "+"
        ! CHECK: ElseIfStmt
        else if (p(1)==0.) then
          ! CHECK: PrintStmt
          print *, "0."
        ! CHECK: ElseStmt
        else
          ! CHECK: PrintStmt
          print *, "-"
        ! CHECK: EndIfStmt
        end if
        ! CHECK: <<End IfConstruct>>
        ! CHECK: CaseStmt
      case (2:10)
      ! CHECK: CaseStmt
      case default
        ! Note: label-do-loop are canonicalized into do constructs
        ! CHECK: <<DoConstruct!>>
        ! CHECK: NonLabelDoStmt
        do 22 while(l<=k)
          ! CHECK: IfStmt
          if (p(l)<0.) p(l)=cos(p(l))
          ! CHECK: CallStmt
22        call incr(l)
        ! CHECK: EndDoStmt
       ! CHECK: <<End DoConstruct!>>
      ! CHECK: CaseStmt
      case (100:)
    ! CHECK: EndSelectStmt
    end select
  ! CHECK: <<End CaseConstruct!>>
  ! CHECK: EndBlockStmt
  end block
  ! CHECK: <<End BlockConstruct!>>

  ! CHECK-NOT: WhereConstruct
  ! CHECK: WhereStmt
  where (x > 1.) x = x/2.

  ! CHECK: <<WhereConstruct>>
  ! CHECK: WhereConstructStmt
  where (x == 0.)
    ! CHECK: AssignmentStmt
    x = 0.01
  ! CHECK: MaskedElsewhereStmt
  elsewhere (x < 0.5)
    ! CHECK: AssignmentStmt
    x = x*2.
    ! CHECK: <<WhereConstruct>>
    where (y > 0.4)
      ! CHECK: AssignmentStmt
      y = y/2.
    end where
    ! CHECK: <<End WhereConstruct>>
  ! CHECK: ElsewhereStmt
  elsewhere
    ! CHECK: AssignmentStmt
    x = x + 1.
  ! CHECK: EndWhereStmt
  end where
  ! CHECK: <<End WhereConstruct>>

  ! CHECK-NOT: ForAllConstruct
  ! CHECK: ForallStmt
  forall (i = 1:5) x(i) = y(i)

  ! CHECK: <<ForallConstruct>>
  ! CHECK: ForallConstructStmt
  forall (i = 1:5)
    ! CHECK: AssignmentStmt
    x(i) = x(i) + y(10*i)
  ! CHECK: EndForallStmt
  end forall
  ! CHECK: <<End ForallConstruct>>

  ! CHECK: DeallocateStmt
  deallocate(x)
end

! CHECK: Module test
module test
  !! When derived type processing is implemented, remove all instances of:
  !!  - !![disable]
  !!  -  COM: 
  !![disable]type :: a_type
  !![disable]  integer :: x
  !![disable]end type
  !![disable]type, extends(a_type) :: b_type
  !![disable]  integer :: y
  !![disable]end type
  interface
     subroutine ss(aa)
       ! CHECK: CompilerDirective
       !DIR$ IGNORE_TKR aa
       integer :: aa
     end subroutine ss
  end interface
contains
  ! CHECK: Function foo
  function foo(x)
    real x(..)
    integer :: foo
    ! CHECK: <<SelectRankConstruct!>>
    ! CHECK: SelectRankStmt
    select rank(x)
      ! CHECK: SelectRankCaseStmt
      rank (0)
        ! CHECK: AssignmentStmt
        foo = 0
      ! CHECK: SelectRankCaseStmt
      rank (*)
        ! CHECK: AssignmentStmt
        foo = -1
      ! CHECK: SelectRankCaseStmt
      rank (1)
        ! CHECK: AssignmentStmt
        foo = 1
      ! CHECK: SelectRankCaseStmt
      rank default
        ! CHECK: AssignmentStmt
        foo = 2
    ! CHECK: EndSelectStmt
    end select
    ! CHECK: <<End SelectRankConstruct!>>
  end function

  ! CHECK: Function bar
  function bar(x)
    class(*) :: x
    ! CHECK: <<SelectTypeConstruct!>>
    ! CHECK: SelectTypeStmt
    select type(x)
      ! CHECK: TypeGuardStmt
      type is (integer)
        ! CHECK: AssignmentStmt
        bar = 0
      !![disable]! COM: CHECK: TypeGuardStmt
      !![disable]class is (a_type)
      !![disable]  ! COM: CHECK: AssignmentStmt
      !![disable]  bar = 1
      !![disable]  ! COM: CHECK: ReturnStmt
      !![disable]  return
      ! CHECK: TypeGuardStmt
      class default
        ! CHECK: AssignmentStmt
        bar = -1
    ! CHECK: EndSelectStmt
    end select
    ! CHECK: <<End SelectTypeConstruct!>>
  end function

  ! CHECK: Subroutine sub
  subroutine sub(a)
    real(4):: a
    ! CHECK: CompilerDirective
    !DIR$ IGNORE_TKR a
  end subroutine


end module

! CHECK: Subroutine altreturn
subroutine altreturn(i, j, *, *)
  ! CHECK: <<IfConstruct!>>
  if (i>j) then
    ! CHECK: ReturnStmt
    return 1
  else
    ! CHECK: ReturnStmt
    return 2
  end if
  ! CHECK: <<End IfConstruct!>>
end subroutine


! Remaining TODO

! CHECK: Subroutine iostmts
subroutine iostmts(filename, a, b, c)
  character(*) :: filename
  integer :: length
  logical :: file_is_opened
  real, a, b ,c
  ! CHECK: InquireStmt
  inquire(file=filename, opened=file_is_opened)
  ! CHECK: <<IfConstruct>>
  if (file_is_opened) then
    ! CHECK: OpenStmt
    open(10, FILE=filename)
  end if
  ! CHECK: <<End IfConstruct>>
  ! CHECK: ReadStmt
  read(10, *) length
  ! CHECK: RewindStmt
  rewind 10
  ! CHECK-NOT: NamelistStmt
  namelist /nlist/ a, b, c
  ! CHECK: WriteStmt
  write(10, NML=nlist)
  ! CHECK: BackspaceStmt
  backspace(10)
  ! CHECK: FormatStmt
1 format (1PE12.4)
  ! CHECK: WriteStmt
  write (10, 1) a
  ! CHECK: EndfileStmt
  endfile 10
  ! CHECK: FlushStmt
  flush 10
  ! CHECK: WaitStmt
  wait(10)
  ! CHECK: CloseStmt
  close(10)
end subroutine


! CHECK: Subroutine sub2
subroutine sub2()
  integer :: i, j, k, l
  i = 0
1 j = i
  ! CHECK: ContinueStmt
2 continue
  i = i+1
3 j = j+1
! CHECK: ArithmeticIfStmt
  if (j-i) 3, 4, 5
  ! CHECK: GotoStmt
4  goto 6

! FIXME: is name resolution on assigned goto broken/todo ?
! WILLCHECK: AssignStmt
!55 assign 6 to label
! WILLCHECK: AssignedGotoStmt
!66  go to label (5, 6)

! CHECK: ComputedGotoStmt
  go to (5, 6), 1 + mod(i, 2)
5 j = j + 1
6 i = i + j/2

  ! CHECK: <<DoConstruct!>>
  do1: do k=1,10
    ! CHECK: <<DoConstruct!>>
    do2: do l=5,20
      ! CHECK: CycleStmt
      cycle do1
      ! CHECK: ExitStmt
      exit do2
    end do do2
    ! CHECK: <<End DoConstruct!>>
  end do do1
  ! CHECK: <<End DoConstruct!>>

  ! CHECK: PauseStmt
  pause 7
  ! CHECK: StopStmt
  stop
end subroutine


! CHECK: Subroutine sub3
subroutine sub3()
 print *, "normal"
  ! CHECK: EntryStmt
 entry sub4entry()
 print *, "test"
end subroutine

! CHECK: Subroutine sub4
subroutine sub4()
  integer :: i
  print*, "test"
  data i /1/
end subroutine