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