mirror of
https://github.com/llvm/llvm-project.git
synced 2025-04-17 03:56:42 +00:00
b47c88eaef
Lowering code currently allows for directives inside a program or
subprogram, or outside any program unit. Directives may also appear
in the specification part of a module, as in:
module mm
interface
subroutine ss(aa)
!dir$ ignore_tkr(tkr) aa
integer :: aa(*)
end subroutine ss
end interface
end module
With some exceptions such as OpenMP directives, most directives are
currently ignored, so this code should generate an "ignoring all compiler
directives" message.
343 lines
7.4 KiB
Fortran
343 lines
7.4 KiB
Fortran
! 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
|