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
|
! { dg-do run }
! Various runtime tests of PROCEDURE declarations.
! Contributed by Janus Weil <jaydub66@gmail.com>
module m
use ISO_C_BINDING
abstract interface
subroutine csub() bind(c)
end subroutine csub
end interface
integer, parameter :: ckind = C_FLOAT_COMPLEX
abstract interface
function stub() bind(C)
import ckind
complex(ckind) stub
end function
end interface
procedure():: mp1
procedure(real), private:: mp2
procedure(mfun), public:: mp3
procedure(csub), public, bind(c) :: c, d
procedure(csub), public, bind(c, name="myB") :: b
procedure(stub), bind(C) :: e
contains
real function mfun(x,y)
real x,y
mfun=4.2
end function
subroutine bar(a,b)
implicit none
interface
subroutine a()
end subroutine a
end interface
optional :: a
procedure(a), optional :: b
end subroutine bar
subroutine bar2(x)
abstract interface
character function abs_fun()
end function
end interface
procedure(abs_fun):: x
end subroutine
end module
program p
implicit none
abstract interface
subroutine abssub(x)
real x
end subroutine
end interface
integer i
real r
procedure(integer):: p1
procedure(fun):: p2
procedure(abssub):: p3
procedure(sub):: p4
procedure():: p5
procedure(p4):: p6
procedure(integer) :: p7
i=p1()
if (i /= 5) call abort()
i=p2(3.1)
if (i /= 3) call abort()
r=4.2
call p3(r)
if (abs(r-5.2)>1e-6) call abort()
call p4(r)
if (abs(r-3.7)>1e-6) call abort()
call p5()
call p6(r)
if (abs(r-7.4)>1e-6) call abort()
i=p7(4)
if (i /= -8) call abort()
r=dummytest(p3)
if (abs(r-2.1)>1e-6) call abort()
contains
integer function fun(x)
real x
fun=7
end function
subroutine sub(x)
real x
end subroutine
real function dummytest(dp)
procedure(abssub):: dp
real y
y=1.1
call dp(y)
dummytest=y
end function
end program p
integer function p1()
p1 = 5
end function
integer function p2(x)
real x
p2 = int(x)
end function
subroutine p3(x)
real,intent(inout):: x
x=x+1.0
end subroutine
subroutine p4(x)
real,intent(inout):: x
x=x-1.5
end subroutine
subroutine p5()
end subroutine
subroutine p6(x)
real,intent(inout):: x
x=x*2.
end subroutine
function p7(x)
implicit none
integer :: x, p7
p7 = x*(-2)
end function
|
