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) STOP 1
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!") STOP 2
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!") STOP 3
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!") STOP 4
151   if (trim (message2) .ne. "adieu, world!") STOP 5
152
153   call clear_messages
154   call smurf ! Checks host association of 'say_hello'
155   if (trim (message) .ne. "Hello, world!") STOP 6
156
157   call clear_messages
158   bar%greeting = "farewell     "
159   call bar%farewell
160   if (trim (message) .ne. "farewell") STOP 7
161   if (trim (message2) .ne. "adieu, world!") STOP 8
162
163   if (realf(2.0) .ne. 4.0) STOP 9! Check module procedure with explicit result
164   if (intf(2) .ne. 10) STOP 10! ditto
165   if (realg(3.0) .ne. 9.0) STOP 11! Check module procedure with function declaration result
166   if (intg(3) .ne. 9) STOP 12! ditto
167 contains
168   subroutine clear_messages
169     message = ""
170     message2 = ""
171   end subroutine
172 end program
173