flang/test/Semantics/call09.f90

   1 ! RUN: %S/test_errors.sh %s %t %flang_fc1
   2 ! REQUIRES: shell
   3 ! Test 15.5.2.9(2,3,5) dummy procedure requirements
   4 ! C843
   5 !   An entity with the INTENT attribute shall be a dummy data object or a
   6 !   dummy procedure pointer.
   7
   8 module m
   9  contains
  10
  11   integer function intfunc(x)
  12     integer, intent(in) :: x
  13     intfunc = x
  14   end function
  15   real function realfunc(x)
  16     real, intent(in) :: x
  17     realfunc = x
  18   end function
  19
  20   subroutine s01(p)
  21     procedure(realfunc), pointer, intent(in) :: p
  22   end subroutine
  23   subroutine s02(p)
  24     procedure(realfunc), pointer :: p
  25   end subroutine
  26   subroutine s03(p)
  27     procedure(realfunc) :: p
  28   end subroutine
  29   subroutine s04(p)
  30     !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
  31     procedure(realfunc), intent(in) :: p
  32   end subroutine
  33
  34   subroutine selemental1(p)
  35     procedure(cos) :: p ! ok
  36   end subroutine
  37
  38   real elemental function elemfunc(x)
  39     real, intent(in) :: x
  40     elemfunc = x
  41   end function
  42   subroutine selemental2(p)
  43     !ERROR: A dummy procedure may not be ELEMENTAL
  44     procedure(elemfunc) :: p
  45   end subroutine
  46
  47   function procptr()
  48     procedure(realfunc), pointer :: procptr
  49     procptr => realfunc
  50   end function
  51   function intprocptr()
  52     procedure(intfunc), pointer :: intprocptr
  53     intprocptr => intfunc
  54   end function
  55
  56   subroutine test1 ! 15.5.2.9(5)
  57     intrinsic :: sin
  58     procedure(realfunc), pointer :: p
  59     procedure(intfunc), pointer :: ip
  60     integer, pointer :: intPtr
  61     external :: extfunc
  62     external :: extfuncPtr
  63     pointer :: extfuncPtr
  64     p => realfunc
  65     ip => intfunc
  66     call s01(realfunc) ! ok
  67     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
  68     call s01(intfunc)
  69     call s01(p) ! ok
  70     call s01(procptr()) ! ok
  71     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
  72     call s01(intprocptr())
  73     call s01(null()) ! ok
  74     call s01(null(p)) ! ok
  75     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
  76     call s01(null(ip))
  77     call s01(sin) ! ok
  78     !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
  79     call s01(null(intPtr))
  80     !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
  81     call s01(B"0101")
  82     !ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
  83     call s01(extfunc)
  84     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
  85     call s02(realfunc)
  86     call s02(p) ! ok
  87     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
  88     call s02(ip)
  89     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
  90     call s02(procptr())
  91     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
  92     call s02(null())
  93     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
  94     call s02(null(p))
  95     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
  96     call s02(sin)
  97     !ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
  98     call s02(extfunc)
  99     !ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
 100     call s03(extfuncPtr)
 101   end subroutine
 102
 103   subroutine callsub(s)
 104     call s
 105   end subroutine
 106   subroutine takesrealfunc1(f)
 107     external f
 108     real f
 109   end subroutine
 110   subroutine takesrealfunc2(f)
 111     x = f(1)
 112   end subroutine
 113   subroutine forwardproc(p)
 114     implicit none
 115     external :: p ! function or subroutine not known
 116     call foo(p)
 117   end subroutine
 118
 119   subroutine test2(unknown,ds,drf,dif) ! 15.5.2.9(2,3)
 120     external :: unknown, ds, drf, dif
 121     real :: drf
 122     integer :: dif
 123     procedure(callsub), pointer :: ps
 124     procedure(realfunc), pointer :: prf
 125     procedure(intfunc), pointer :: pif
 126     call ds ! now we know that's it's a subroutine
 127     call callsub(callsub) ! ok apart from infinite recursion
 128     call callsub(unknown) ! ok
 129     call callsub(ds) ! ok
 130     call callsub(ps) ! ok
 131     call takesrealfunc1(realfunc) ! ok
 132     call takesrealfunc1(unknown) ! ok
 133     call takesrealfunc1(drf) ! ok
 134     call takesrealfunc1(prf) ! ok
 135     call takesrealfunc2(realfunc) ! ok
 136     call takesrealfunc2(unknown) ! ok
 137     call takesrealfunc2(drf) ! ok
 138     call takesrealfunc2(prf) ! ok
 139     call forwardproc(callsub) ! ok
 140     call forwardproc(realfunc) ! ok
 141     call forwardproc(intfunc) ! ok
 142     call forwardproc(unknown) ! ok
 143     call forwardproc(ds) ! ok
 144     call forwardproc(drf) ! ok
 145     call forwardproc(dif) ! ok
 146     call forwardproc(ps) ! ok
 147     call forwardproc(prf) ! ok
 148     call forwardproc(pif) ! ok
 149     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 150     call callsub(realfunc)
 151     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 152     call callsub(intfunc)
 153     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 154     call callsub(drf)
 155     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 156     call callsub(dif)
 157     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 158     call callsub(prf)
 159     !ERROR: Actual argument associated with procedure dummy argument 's=' is a function but must be a subroutine
 160     call callsub(pif)
 161     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 162     call takesrealfunc1(callsub)
 163     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 164     call takesrealfunc1(ds)
 165     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 166     call takesrealfunc1(ps)
 167     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 168     call takesrealfunc1(intfunc)
 169     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 170     call takesrealfunc1(dif)
 171     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 172     call takesrealfunc1(pif)
 173     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 174     call takesrealfunc1(intfunc)
 175     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 176     call takesrealfunc2(callsub)
 177     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 178     call takesrealfunc2(ds)
 179     !ERROR: Actual argument associated with procedure dummy argument 'f=' is a subroutine but must be a function
 180     call takesrealfunc2(ps)
 181     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 182     call takesrealfunc2(intfunc)
 183     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 184     call takesrealfunc2(dif)
 185     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 186     call takesrealfunc2(pif)
 187     !ERROR: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
 188     call takesrealfunc2(intfunc)
 189   end subroutine
 190 end module