llvm-project/flang/test/Semantics/entry01.f90

! RUN: %python %S/test_errors.py %s %flang_fc1
! Tests valid and invalid ENTRY statements

module m1
  !ERROR: ENTRY may appear only in a subroutine or function
  entry badentryinmodule
  interface
    module subroutine separate
    end subroutine
  end interface
 contains
  subroutine modproc
    entry entryinmodproc ! ok
    block
      !ERROR: ENTRY may not appear in an executable construct
      entry badentryinblock ! C1571
    end block
    if (.true.) then
      !ERROR: ENTRY may not appear in an executable construct
      entry ibadconstr() ! C1571
    end if
   contains
    subroutine internal
      !ERROR: ENTRY may not appear in an internal subprogram
      entry badentryininternal ! C1571
    end subroutine
  end subroutine
end module

submodule(m1) m1s1
 contains
  module procedure separate
    !ERROR: ENTRY may not appear in a separate module procedure
    entry badentryinsmp ! 1571
  end procedure
end submodule

program main
  !ERROR: ENTRY may appear only in a subroutine or function
  entry badentryinprogram ! C1571
end program

block data bd1
  !ERROR: ENTRY may appear only in a subroutine or function
  entry badentryinbd ! C1571
end block data

subroutine subr(goodarg1)
  real, intent(in) :: goodarg1
  real :: goodarg2
  !ERROR: A dummy argument may not also be a named constant
  integer, parameter :: badarg1 = 1
  type :: badarg2
  end type
  common /badarg3/ x
  namelist /badarg4/ x
  !ERROR: A dummy argument must not be initialized
  integer :: badarg5 = 2
  entry okargs(goodarg1, goodarg2)
  !ERROR: RESULT(br1) may appear only in a function
  entry badresult() result(br1) ! C1572
  !ERROR: ENTRY dummy argument 'badarg2' is previously declared as an item that may not be used as a dummy argument
  !ERROR: ENTRY dummy argument 'badarg4' is previously declared as an item that may not be used as a dummy argument
  entry badargs(badarg1,badarg2,badarg3,badarg4,badarg5)
end subroutine

function ifunc()
  integer :: ifunc
  integer :: ibad1
  type :: ibad2
  end type
  save :: ibad3
  real :: weird1
  double precision :: weird2
  complex :: weird3
  logical :: weird4
  character :: weird5
  type(ibad2) :: weird6
  integer :: iarr(1)
  integer, allocatable :: alloc
  integer, pointer :: ptr
  entry iok1()
  !ERROR: ENTRY name 'ibad1' may not be declared when RESULT() is present
  entry ibad1() result(ibad1res) ! C1570
  !ERROR: 'ibad2' was previously declared as an item that may not be used as a function result
  entry ibad2()
  !ERROR: ENTRY in a function may not have an alternate return dummy argument
  entry ibadalt(*) ! C1573
  !ERROR: RESULT(ifunc) may not have the same name as the function
  entry isameres() result(ifunc) ! C1574
  entry iok()
  !ERROR: RESULT(iok) may not have the same name as an ENTRY in the function
  entry isameres2() result(iok) ! C1574
  entry isameres3() result(iok2) ! C1574
  entry iok2()
  !These cases are all acceptably incompatible
  entry iok3() result(weird1)
  entry iok4() result(weird2)
  entry iok5() result(weird3)
  entry iok6() result(weird4)
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry ibadt1() result(weird5)
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry ibadt2() result(weird6)
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry ibadt3() result(iarr)
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry ibadt4() result(alloc)
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry ibadt5() result(ptr)
  call isubr
  !ERROR: 'isubr' was previously called as a subroutine
  entry isubr()
  continue ! force transition to execution part
  entry implicit()
  implicit = 666 ! ok, just ensure that it works
end function

function chfunc() result(chr)
  character(len=1) :: chr
  character(len=2) :: chr1
  !ERROR: Result of ENTRY is not compatible with result of containing function
  entry chfunc1() result(chr1)
end function

subroutine externals
  !ERROR: 'subr' is already defined as a global identifier
  entry subr
  !ERROR: 'ifunc' is already defined as a global identifier
  entry ifunc
  !ERROR: 'm1' is already defined as a global identifier
  entry m1
  !ERROR: 'iok1' is already defined as a global identifier
  entry iok1
  integer :: ix
  ix = iproc()
  !ERROR: 'iproc' was previously called as a function
  entry iproc
end subroutine

module m2
  !ERROR: EXTERNAL attribute not allowed on 'm2entry2'
  external m2entry2
 contains
  subroutine m2subr1
    entry m2entry1 ! ok
    entry m2entry2 ! NOT ok
    entry m2entry3 ! ok
  end subroutine
end module

subroutine usem2
  use m2
  interface
    subroutine simplesubr
    end subroutine
  end interface
  procedure(simplesubr), pointer :: p
  p => m2subr1 ! ok
  p => m2entry1 ! ok
  p => m2entry2 ! ok
  p => m2entry3 ! ok
end subroutine

module m3
  interface
    module subroutine m3entry1
    end subroutine
  end interface
 contains
  subroutine m3subr1
    !ERROR: 'm3entry1' is already declared in this scoping unit
    entry m3entry1
  end subroutine
end module

module m4
  interface generic1
    module procedure m4entry1
  end interface
  interface generic2
    module procedure m4entry2
  end interface
  interface generic3
    module procedure m4entry3
  end interface
 contains
  subroutine m4subr1
    entry m4entry1 ! in implicit part
    integer :: n = 0
    entry m4entry2 ! in specification part
    n = 123
    entry m4entry3 ! in executable part
    print *, n
  end subroutine
end module

function inone
  implicit none
  integer :: inone
  !ERROR: No explicit type declared for 'implicitbad1'
  entry implicitbad1
  inone = 0 ! force transition to execution part
  !ERROR: No explicit type declared for 'implicitbad2'
  entry implicitbad2
end