3 ! Basic test of submodule functionality.
5 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
9 character(len
= 100) :: message
10 character(len
= 100) :: message2
13 character(len
=15) :: greeting
= "Hello, world! "
14 character(len
=15), private
:: byebye
= "adieu, world! "
16 procedure
:: greet
=> say_hello
17 procedure
:: farewell
=> bye
18 procedure
, private
:: adieu
=> byebye
22 module subroutine say_hello(this
)
23 class(foo
), intent(in
) :: this
26 module subroutine bye(this
)
27 class(foo
), intent(in
) :: this
30 module subroutine byebye(this
, that
)
31 class(foo
), intent(in
) :: this
32 class(foo
), intent(inOUT
), allocatable
:: that
35 module function realf (arg
) result (res
)
39 integer module function intf (arg
)
43 real module function realg (arg
)
47 integer module function intg (arg
)
58 class(foo
), allocatable
:: this
60 message
= "say_hello from SMURF --->"
66 SUBMODULE (foo_interface
) foo_interface_son
69 ! Test module procedure with conventional specification part for dummies
70 module subroutine say_hello(this
)
71 class(foo
), intent(in
) :: this
72 class(foo
), allocatable
:: that
73 allocate (that
, source
= this
)
74 ! call this%farewell ! NOTE WELL: This compiles and causes a crash in run-time
75 ! due to recursion through the call to this procedure from
77 message
= that
%greeting
79 ! Check that descendant module procedure is correctly processed
80 if (intf (77) .ne
. factor
*77) call abort
83 module function realf (arg
) result (res
)
88 end SUBMODULE foo_interface_son
91 ! Check that multiple generations of submodules are OK
92 SUBMODULE (foo_interface
:foo_interface_son
) foo_interface_grandson
100 end SUBMODULE foo_interface_grandson
103 SUBMODULE (foo_interface
) foo_interface_daughter
106 ! Test module procedure with abbreviated declaration and no specification of dummies
108 class(foo
), allocatable
:: that
109 call say_hello (this
)
110 ! check access to a PRIVATE procedure pointer that accesses a private component
111 call this
%adieu (that
)
112 message2
= that
%greeting
115 ! Test module procedure pointed to by PRIVATE component of foo
116 module procedure byebye
117 allocate (that
, source
= this
)
118 ! Access a PRIVATE component of foo
119 that
%greeting
= that
%byebye
122 module procedure intg
126 module procedure realg
130 end SUBMODULE foo_interface_daughter
139 call bar
%greet
! typebound call
140 if (trim (message
) .ne
. "Hello, world!") call abort
143 bar
%greeting
= "G'day, world!"
144 call say_hello(bar
) ! Checks use association of 'say_hello'
145 if (trim (message
) .ne
. "G'day, world!") call abort
148 bar
%greeting
= "Hi, world!"
149 call bye(bar
) ! Checks use association in another submodule
150 if (trim (message
) .ne
. "Hi, world!") call abort
151 if (trim (message2
) .ne
. "adieu, world!") call abort
154 call smurf
! Checks host association of 'say_hello'
155 if (trim (message
) .ne
. "Hello, world!") call abort
158 bar
%greeting
= "farewell "
160 if (trim (message
) .ne
. "farewell") call abort
161 if (trim (message2
) .ne
. "adieu, world!") call abort
163 if (realf(2.0) .ne
. 4.0) call abort
! Check module procedure with explicit result
164 if (intf(2) .ne
. 10) call abort
! ditto
165 if (realg(3.0) .ne
. 9.0) call abort
! Check module procedure with function declaration result
166 if (intg(3) .ne
. 9) call abort
! ditto
168 subroutine clear_messages