1! { dg-do run }
2!
3! Basic test of submodule functionality.
4!
5! Contributed by Paul Thomas  <pault@gcc.gnu.org>
6!
7 module foo_interface
8   implicit none
9   character(len = 100) :: message
10   character(len = 100) :: message2
11
12   type foo
13     character(len=15) :: greeting = "Hello, world!  "
14     character(len=15), private :: byebye = "adieu, world!  "
15   contains
16     procedure :: greet => say_hello
17     procedure :: farewell => bye
18     procedure, private :: adieu => byebye
19   end type foo
20
21   interface
22     module subroutine say_hello(this)
23       class(foo), intent(in) :: this
24     end subroutine
25
26     module subroutine bye(this)
27       class(foo), intent(in) :: this
28     end subroutine
29
30     module subroutine byebye(this, that)
31       class(foo), intent(in) :: this
32       class(foo), intent(inOUT), allocatable :: that
33     end subroutine
34
35     module function realf (arg) result (res)
36       real :: arg, res
37     end function
38
39     integer module function intf (arg)
40       integer :: arg
41     end function
42
43     real module function realg (arg)
44       real :: arg
45     end function
46
47     integer module function intg (arg)
48       integer :: arg
49     end function
50
51   end interface
52
53   integer :: factor = 5
54
55 contains
56
57   subroutine smurf
58     class(foo), allocatable :: this
59     allocate (this)
60     message = "say_hello from SMURF --->"
61     call say_hello (this)
62   end subroutine
63 end module
64
65!
66  SUBMODULE (foo_interface) foo_interface_son
67!
68  contains
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
76!                                               say hello.
77       message = that%greeting
78
79! Check that descendant module procedure is correctly processed
80       if (intf (77) .ne. factor*77) call abort
81     end subroutine
82
83     module function realf (arg) result (res)
84       real :: arg, res
85       res = 2*arg
86     end function
87
88  end SUBMODULE foo_interface_son
89
90!
91! Check that multiple generations of submodules are OK
92  SUBMODULE (foo_interface:foo_interface_son) foo_interface_grandson
93!
94  contains
95
96     module procedure intf
97       intf = factor*arg
98     end PROCEDURE
99
100  end SUBMODULE foo_interface_grandson
101
102!
103  SUBMODULE (foo_interface) foo_interface_daughter
104!
105  contains
106! Test module procedure with abbreviated declaration and no specification of dummies
107     module procedure bye
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
113     end PROCEDURE
114
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
120     end PROCEDURE
121
122     module procedure intg
123       intg = 3*arg
124     end PROCEDURE
125
126     module procedure realg
127       realg = 3*arg
128     end PROCEDURE
129
130  end SUBMODULE foo_interface_daughter
131
132!
133 program try
134   use foo_interface
135   implicit none
136   type(foo) :: bar
137
138   call clear_messages
139   call bar%greet ! typebound call
140   if (trim (message) .ne. "Hello, world!") call abort
141
142   call clear_messages
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
146
147   call clear_messages
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
152
153   call clear_messages
154   call smurf ! Checks host association of 'say_hello'
155   if (trim (message) .ne. "Hello, world!") call abort
156
157   call clear_messages
158   bar%greeting = "farewell     "
159   call bar%farewell
160   if (trim (message) .ne. "farewell") call abort
161   if (trim (message2) .ne. "adieu, world!") call abort
162
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
167 contains
168   subroutine clear_messages
169     message = ""
170     message2 = ""
171   end subroutine
172 end program
173! { dg-final { cleanup-submodules "foo_interface@foo_interface_son" } }
174! { dg-final { cleanup-submodules "foo_interface@foo_interface_grandson" } }
175! { dg-final { cleanup-submodules "foo_interface@foo_interface_daughter" } }
176