1! { dg-do run }
2!
3! PR fortran/99171
4!
5! Check dummy procedure arguments, especially optional ones
6!
7module m
8  use iso_c_binding
9  implicit none (type, external)
10  integer :: cnt
11  integer :: cnt2
12contains
13  subroutine proc()
14    cnt = cnt + 1
15  end subroutine
16
17  subroutine proc2()
18    cnt2 = cnt2 + 1
19  end subroutine
20
21  subroutine check(my_proc)
22    procedure(proc) :: my_proc
23    cnt = 42
24    call my_proc()
25    if (cnt /= 43) stop 1
26
27    !$omp parallel
28      call my_proc()
29    !$omp end parallel
30    if (cnt <= 43) stop 2
31  end
32
33  subroutine check_opt(my_proc)
34    procedure(proc), optional :: my_proc
35    logical :: is_present
36    is_present = present(my_proc)
37    cnt = 55
38    if (present (my_proc)) then
39      call my_proc()
40      if (cnt /= 56) stop 3
41    endif
42
43    !$omp parallel
44      if (is_present .neqv. present (my_proc)) stop 4
45      if (present (my_proc)) then
46        call my_proc()
47        if (cnt <= 56) stop 5
48      end if
49    !$omp end parallel
50    if (is_present) then
51      if (cnt <= 56) stop 6
52    else if (cnt /= 55) then
53      stop 7
54    end if
55  end
56
57  subroutine check_ptr(my_proc)
58    procedure(proc), pointer :: my_proc
59    logical :: is_assoc
60    integer :: mycnt
61    is_assoc = associated (my_proc)
62
63    cnt = 10
64    cnt2 = 20
65    if (associated (my_proc)) then
66      call my_proc()
67      if (cnt /= 11 .or. cnt2 /= 20) stop 8
68    endif
69
70    !$omp parallel
71      if (is_assoc .neqv. associated (my_proc)) stop 9
72      if (associated (my_proc)) then
73        if (.not. associated (my_proc, proc)) stop 10
74        call my_proc()
75        if (cnt <= 11 .or. cnt2 /= 20) stop 11
76      else if (cnt /= 10 .or. cnt2 /= 20) then
77        stop 12
78      end if
79    !$omp end parallel
80    if (is_assoc .neqv. associated (my_proc)) stop 13
81    if (associated (my_proc)) then
82      if (cnt <= 11 .or. cnt2 /= 20) stop 14
83    else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
84      stop 15
85    end if
86
87    cnt = 30
88    cnt2 = 40
89    mycnt = 0
90    !$omp parallel shared(mycnt)
91      !$omp critical
92         my_proc => proc2
93         if (.not.associated (my_proc, proc2)) stop 17
94         mycnt = mycnt + 1
95         call my_proc()
96         if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 18
97      !$omp end critical
98    !$omp end parallel
99    if (.not.associated (my_proc, proc2)) stop 19
100    if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 20
101  end
102
103  subroutine check_ptr_opt(my_proc)
104    procedure(proc), pointer, optional :: my_proc
105    logical :: is_assoc, is_present
106    integer :: mycnt
107    is_assoc = .false.
108    is_present = present(my_proc)
109
110    cnt = 10
111    cnt2 = 20
112    if (present (my_proc)) then
113      is_assoc = associated (my_proc)
114      if (associated (my_proc)) then
115        call my_proc()
116        if (cnt /= 11 .or. cnt2 /= 20) stop 21
117      endif
118   end if
119
120    !$omp parallel
121      if (is_present .neqv. present (my_proc)) stop 22
122      if (present (my_proc)) then
123        if (is_assoc .neqv. associated (my_proc)) stop 23
124        if (associated (my_proc)) then
125          if (.not. associated (my_proc, proc)) stop 24
126          call my_proc()
127          if (cnt <= 11 .or. cnt2 /= 20) stop 25
128        else if (cnt /= 10 .or. cnt2 /= 20) then
129          stop 26
130        end if
131      end if
132    !$omp end parallel
133    if (present (my_proc)) then
134      if (is_assoc .neqv. associated (my_proc)) stop 27
135      if (associated (my_proc)) then
136        if (cnt <= 11 .or. cnt2 /= 20) stop 28
137      else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
138        stop 29
139      end if
140    end if
141
142    cnt = 30
143    cnt2 = 40
144    mycnt = 0
145    !$omp parallel shared(mycnt)
146      if (is_present .neqv. present (my_proc)) stop 30
147      !$omp critical
148         if (present (my_proc)) then
149           my_proc => proc2
150           if (.not.associated (my_proc, proc2)) stop 31
151           mycnt = mycnt + 1
152           call my_proc()
153           if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 32
154         end if
155      !$omp end critical
156    !$omp end parallel
157    if (present (my_proc)) then
158      if (.not.associated (my_proc, proc2)) stop 33
159      if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 34
160    end if
161  end
162
163  ! ----------------------
164
165  subroutine cfun_check(my_cfun)
166    type(c_funptr) :: my_cfun
167    procedure(proc), pointer :: pptr
168    logical :: has_cfun
169
170    has_cfun = c_associated (my_cfun)
171    pptr => null()
172    cnt = 42
173    call c_f_procpointer (my_cfun, pptr)
174    if (has_cfun) then
175      call pptr()
176      if (cnt /= 43) stop 35
177    end if
178
179    pptr => null()
180    !$omp parallel
181      if (has_cfun .neqv. c_associated (my_cfun)) stop 36
182      !$omp critical
183        call c_f_procpointer (my_cfun, pptr)
184      !$omp end critical
185      if (has_cfun) then
186        call pptr()
187        if (cnt <= 43) stop 37
188      else
189        if (associated (pptr)) stop 38
190      end if
191    !$omp end parallel
192  end
193
194  subroutine cfun_check_opt(my_cfun)
195    type(c_funptr), optional :: my_cfun
196    procedure(proc), pointer :: pptr
197    logical :: has_cfun, is_present
198
199    has_cfun = .false.
200    is_present = present (my_cfun)
201    if (is_present) has_cfun = c_associated (my_cfun)
202
203    cnt = 1
204    pptr => null()
205    !$omp parallel
206      if (is_present .neqv. present (my_cfun)) stop 39
207      if (is_present) then
208        if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 40
209        !$omp critical
210          call c_f_procpointer (my_cfun, pptr)
211        !$omp end critical
212        if (has_cfun) then
213          call pptr()
214          if (cnt <= 1) stop 41
215        else
216          if (associated (pptr)) stop 42
217        end if
218      end if
219    !$omp end parallel
220  end
221
222  subroutine cfun_check_ptr(my_cfun)
223    type(c_funptr), pointer :: my_cfun
224    procedure(proc), pointer :: pptr
225    logical :: has_cfun, is_assoc
226
227    has_cfun = .false.
228    is_assoc = associated (my_cfun)
229    if (is_assoc) has_cfun = c_associated (my_cfun)
230
231    cnt = 1
232    pptr => null()
233    !$omp parallel
234      if (is_assoc .neqv. associated (my_cfun)) stop 43
235      if (is_assoc) then
236        if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 44
237        !$omp critical
238          call c_f_procpointer (my_cfun, pptr)
239        !$omp end critical
240        if (has_cfun) then
241          call pptr()
242          if (cnt <= 1) stop 45
243        else
244          if (associated (pptr)) stop 46
245        end if
246      end if
247    !$omp end parallel
248
249    cnt = 42
250    cnt2 = 1
251    pptr => null()
252    !$omp parallel
253      if (is_assoc .neqv. associated (my_cfun)) stop 47
254      if (is_assoc) then
255        !$omp critical
256          my_cfun = c_funloc (proc2)
257          call c_f_procpointer (my_cfun, pptr)
258        !$omp end critical
259        if (.not. associated (pptr, proc2)) stop 48
260        if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 49
261        call pptr()
262        if (cnt /= 42 .or. cnt2 <= 1) stop 50
263      end if
264    !$omp end parallel
265    if (is_assoc) then
266      if (.not. associated (pptr, proc2)) stop 51
267      if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 52
268    else
269      if (associated (pptr)) stop 53
270    end if
271  end
272
273  subroutine cfun_check_ptr_opt (my_cfun)
274    type(c_funptr), pointer, optional :: my_cfun
275    procedure(proc), pointer :: pptr
276    logical :: is_present, has_cfun, is_assoc
277
278    has_cfun = .false.
279    is_assoc = .false.
280    is_present = present (my_cfun)
281    if (is_present) then
282      is_assoc = associated (my_cfun)
283      if (is_assoc) has_cfun = c_associated (my_cfun)
284    end if
285
286    cnt = 1
287    pptr => null()
288    !$omp parallel
289      if (is_present .neqv. present (my_cfun)) stop 54
290      if (is_present) then
291        if (is_assoc .neqv. associated (my_cfun)) stop 55
292        if (is_assoc) then
293          if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 56
294          !$omp critical
295            call c_f_procpointer (my_cfun, pptr)
296          !$omp end critical
297          if (has_cfun) then
298            call pptr()
299            if (cnt <= 1) stop 57
300          else
301            if (associated (pptr)) stop 58
302          end if
303        end if
304      end if
305    !$omp end parallel
306
307    cnt = 42
308    cnt2 = 1
309    pptr => null()
310    !$omp parallel
311      if (is_present .neqv. present (my_cfun)) stop 59
312      if (is_present) then
313        if (is_assoc .neqv. associated (my_cfun)) stop 60
314        if (is_assoc) then
315          !$omp critical
316            my_cfun = c_funloc (proc2)
317            call c_f_procpointer (my_cfun, pptr)
318          !$omp end critical
319          if (.not. associated (pptr, proc2)) stop 61
320          if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 62
321          call pptr()
322          if (cnt /= 42 .or. cnt2 <= 1) stop 63
323        end if
324      end if
325    !$omp end parallel
326    if (is_present .and. is_assoc) then
327      if (.not. associated (pptr, proc2)) stop 64
328      if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 65
329    else
330      if (associated (pptr)) stop 66
331    end if
332  end
333end module m
334
335
336
337program main
338  use m
339  implicit none (type, external)
340  procedure(proc), pointer :: pptr
341  type(c_funptr), target :: cfun
342  type(c_funptr), pointer :: cfun_ptr
343
344  call check(proc)
345  call check_opt()
346  call check_opt(proc)
347
348  pptr => null()
349  call check_ptr(pptr)
350  pptr => proc
351  call check_ptr(pptr)
352
353  call check_ptr_opt()
354  pptr => null()
355  call check_ptr_opt(pptr)
356  pptr => proc
357  call check_ptr_opt(pptr)
358
359  ! -------------------
360  pptr => null()
361
362  cfun = c_funloc (pptr)
363  call cfun_check(cfun)
364
365  cfun = c_funloc (proc)
366  call cfun_check(cfun)
367
368  call cfun_check_opt()
369
370  cfun = c_funloc (pptr)
371  call cfun_check_opt(cfun)
372
373  cfun = c_funloc (proc)
374  call cfun_check_opt(cfun)
375
376  ! - - - -
377  cfun_ptr => null()
378  call cfun_check_ptr (cfun_ptr)
379
380  cfun = c_funloc (proc)
381  cfun_ptr => cfun
382  call cfun_check_ptr (cfun_ptr)
383
384  ! - - - -
385  call cfun_check_ptr_opt ()
386
387  cfun_ptr => null()
388  call cfun_check_ptr_opt (cfun_ptr)
389
390  cfun = c_funloc (proc)
391  cfun_ptr => cfun
392  call cfun_check_ptr_opt (cfun_ptr)
393end program
394