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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
! { dg-do run }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module mo
contains
function j()
implicit none
procedure(integer),pointer :: j
intrinsic iabs
j => iabs
end function
subroutine sub(y)
integer,intent(inout) :: y
y = y**2
end subroutine
end module
program proc_ptr_14
use mo
implicit none
intrinsic :: iabs
integer :: x
procedure(integer),pointer :: p,p2
procedure(sub),pointer :: ps
p => a()
if (p(-1)/=1) STOP 1
p => b()
if (p(-2)/=2) STOP 2
p => c()
if (p(-3)/=3) STOP 3
ps => d()
x = 4
call ps(x)
if (x/=16) STOP 4
p => dd()
if (p(-4)/=4) STOP 5
ps => e(sub)
x = 5
call ps(x)
if (x/=25) STOP 6
p => ee()
if (p(-5)/=5) STOP 7
p => f()
if (p(-6)/=6) STOP 8
p => g()
if (p(-7)/=7) STOP 9
ps => h(sub)
x = 2
call ps(x)
if (x/=4) STOP 10
p => i()
if (p(-8)/=8) STOP 11
p => j()
if (p(-9)/=9) STOP 12
p => k(p2)
if (p(-10)/=p2(-10)) STOP 13
p => l()
if (p(-11)/=11) STOP 14
contains
function a()
procedure(integer),pointer :: a
a => iabs
end function
function b()
procedure(integer) :: b
pointer :: b
b => iabs
end function
function c()
pointer :: c
procedure(integer) :: c
c => iabs
end function
function d()
pointer :: d
external d
d => sub
end function
function dd()
pointer :: dd
external :: dd
integer :: dd
dd => iabs
end function
function e(arg)
external :: e,arg
pointer :: e
e => arg
end function
function ee()
integer :: ee
external :: ee
pointer :: ee
ee => iabs
end function
function f()
pointer :: f
interface
integer function f(x)
integer,intent(in) :: x
end function
end interface
f => iabs
end function
function g()
interface
integer function g(x)
integer,intent(in) :: x
end function g
end interface
pointer :: g
g => iabs
end function
function h(arg)
interface
subroutine arg(b)
integer,intent(inout) :: b
end subroutine arg
end interface
pointer :: h
interface
subroutine h(a)
integer,intent(inout) :: a
end subroutine h
end interface
h => arg
end function
function i()
pointer :: i
interface
function i(x)
integer :: i,x
intent(in) :: x
end function i
end interface
i => iabs
end function
function k(arg)
procedure(integer),pointer :: k,arg
k => iabs
arg => k
end function
function l()
! we cannot use iabs directly as it is elemental
abstract interface
pure function interf_iabs(x)
integer, intent(in) :: x
end function interf_iabs
end interface
procedure(interf_iabs),pointer :: l
integer :: i
l => iabs
if (l(-11)/=11) STOP 15
end function
end
|
