1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
! { dg-do run }
! Tests the fix for PR36433 in which a check for the array size
! or character length of the actual arguments of foo and bar
! would reject this legal code.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module m
contains
function proc4 (arg, chr)
integer, dimension(10) :: proc4
integer, intent(in) :: arg
character(8), intent(inout) :: chr
proc4 = arg
chr = "proc4"
end function
function chr_proc ()
character(8) :: chr_proc
chr_proc = "chr_proc"
end function
end module
program procPtrTest
use m
character(8) :: chr
interface
function proc_ext (arg, chr)
integer, dimension(10) :: proc_ext
integer, intent(in) :: arg
character(8), intent(inout) :: chr
end function
end interface
! Check the passing of a module function
call foo (proc4, chr)
if (trim (chr) .ne. "proc4") call abort
! Check the passing of an external function
call foo (proc_ext, chr)
! Check the passing of a character function
if (trim (chr) .ne. "proc_ext") call abort
call bar (chr_proc)
contains
subroutine foo (p, chr)
character(8), intent(inout) :: chr
integer :: i(10)
interface
function p (arg, chr)
integer, dimension(10) :: p
integer, intent(in) :: arg
character(8), intent(inout) :: chr
end function
end interface
i = p (99, chr)
if (any(i .ne. 99)) call abort
end subroutine
subroutine bar (p)
interface
function p ()
character(8):: p
end function
end interface
if (p () .ne. "chr_proc") call abort
end subroutine
end program
function proc_ext (arg, chr)
integer, dimension(10) :: proc_ext
integer, intent(in) :: arg
character(8), intent(inout) :: chr
proc_ext = arg
chr = "proc_ext"
end function
|
