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
|
! { dg-do run }
!
! Basic test of submodule functionality.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module foo_interface
implicit none
character(len = 100) :: message
character(len = 100) :: message2
type foo
character(len=15) :: greeting = "Hello, world! "
character(len=15), private :: byebye = "adieu, world! "
contains
procedure :: greet => say_hello
procedure :: farewell => bye
procedure, private :: adieu => byebye
end type foo
interface
module subroutine say_hello(this)
class(foo), intent(in) :: this
end subroutine
module subroutine bye(this)
class(foo), intent(in) :: this
end subroutine
module subroutine byebye(this, that)
class(foo), intent(in) :: this
class(foo), intent(inOUT), allocatable :: that
end subroutine
module function realf (arg) result (res)
real :: arg, res
end function
integer module function intf (arg)
integer :: arg
end function
real module function realg (arg)
real :: arg
end function
integer module function intg (arg)
integer :: arg
end function
end interface
integer :: factor = 5
contains
subroutine smurf
class(foo), allocatable :: this
allocate (this)
message = "say_hello from SMURF --->"
call say_hello (this)
end subroutine
end module
!
SUBMODULE (foo_interface) foo_interface_son
!
contains
! Test module procedure with conventional specification part for dummies
module subroutine say_hello(this)
class(foo), intent(in) :: this
class(foo), allocatable :: that
allocate (that, source = this)
! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time
! due to recursion through the call to this procedure from
! say hello.
message = that%greeting
! Check that descendant module procedure is correctly processed
if (intf (77) .ne. factor*77) STOP 1
end subroutine
module function realf (arg) result (res)
real :: arg, res
res = 2*arg
end function
end SUBMODULE foo_interface_son
!
! Check that multiple generations of submodules are OK
SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson
!
contains
module procedure intf
intf = factor*arg
end PROCEDURE
end SUBMODULE foo_interface_grandson
!
SUBMODULE (foo_interface) foo_interface_daughter
!
contains
! Test module procedure with abbreviated declaration and no specification of dummies
module procedure bye
class(foo), allocatable :: that
call say_hello (this)
! check access to a PRIVATE procedure pointer that accesses a private component
call this%adieu (that)
message2 = that%greeting
end PROCEDURE
! Test module procedure pointed to by PRIVATE component of foo
module procedure byebye
allocate (that, source = this)
! Access a PRIVATE component of foo
that%greeting = that%byebye
end PROCEDURE
module procedure intg
intg = 3*arg
end PROCEDURE
module procedure realg
realg = 3*arg
end PROCEDURE
end SUBMODULE foo_interface_daughter
!
program try
use foo_interface
implicit none
type(foo) :: bar
call clear_messages
call bar%greet ! typebound call
if (trim (message) .ne. "Hello, world!") STOP 2
call clear_messages
bar%greeting = "G'day, world!"
call say_hello(bar) ! Checks use association of 'say_hello'
if (trim (message) .ne. "G'day, world!") STOP 3
call clear_messages
bar%greeting = "Hi, world!"
call bye(bar) ! Checks use association in another submodule
if (trim (message) .ne. "Hi, world!") STOP 4
if (trim (message2) .ne. "adieu, world!") STOP 5
call clear_messages
call smurf ! Checks host association of 'say_hello'
if (trim (message) .ne. "Hello, world!") STOP 6
call clear_messages
bar%greeting = "farewell "
call bar%farewell
if (trim (message) .ne. "farewell") STOP 7
if (trim (message2) .ne. "adieu, world!") STOP 8
if (realf(2.0) .ne. 4.0) STOP 9! Check module procedure with explicit result
if (intf(2) .ne. 10) STOP 10! ditto
if (realg(3.0) .ne. 9.0) STOP 11! Check module procedure with function declaration result
if (intg(3) .ne. 9) STOP 12! ditto
contains
subroutine clear_messages
message = ""
message2 = ""
end subroutine
end program
|
