Commit | Line | Data |
---|---|---|
b811d2c2 | 1 | ! Copyright 2019-2020 Free Software Foundation, Inc. |
aa3cfbda RB |
2 | ! |
3 | ! This program is free software; you can redistribute it and/or modify | |
4 | ! it under the terms of the GNU General Public License as published by | |
5 | ! the Free Software Foundation; either version 3 of the License, or | |
6 | ! (at your option) any later version. | |
7 | ! | |
8 | ! This program is distributed in the hope that it will be useful, | |
9 | ! but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ! GNU General Public License for more details. | |
12 | ! | |
13 | ! You should have received a copy of the GNU General Public License | |
14 | ! along with this program. If not, see <http://www.gnu.org/licenses/> . | |
15 | ||
16 | ! Source code for function-calls.exp. | |
17 | ||
18 | subroutine no_arg_subroutine() | |
19 | end subroutine | |
20 | ||
21 | logical function no_arg() | |
22 | no_arg = .TRUE. | |
23 | end function | |
24 | ||
25 | subroutine run(a) | |
26 | external :: a | |
27 | call a() | |
28 | end subroutine | |
29 | ||
30 | logical function one_arg(x) | |
31 | logical, intent(in) :: x | |
32 | one_arg = x | |
33 | end function | |
34 | ||
35 | integer(kind=4) function one_arg_value(x) | |
36 | integer(kind=4), value :: x | |
37 | one_arg_value = x | |
38 | end function | |
39 | ||
40 | integer(kind=4) function several_arguments(a, b, c) | |
41 | integer(kind=4), intent(in) :: a | |
42 | integer(kind=4), intent(in) :: b | |
43 | integer(kind=4), intent(in) :: c | |
44 | several_arguments = a + b + c | |
45 | end function | |
46 | ||
47 | integer(kind=4) function mix_of_scalar_arguments(a, b, c) | |
48 | integer(kind=4), intent(in) :: a | |
49 | logical(kind=4), intent(in) :: b | |
50 | real(kind=8), intent(in) :: c | |
51 | mix_of_scalar_arguments = a + floor(c) | |
52 | if (b) then | |
53 | mix_of_scalar_arguments=mix_of_scalar_arguments+1 | |
54 | end if | |
55 | end function | |
56 | ||
57 | real(kind=4) function real4_argument(a) | |
58 | real(kind=4), intent(in) :: a | |
59 | real4_argument = a | |
60 | end function | |
61 | ||
62 | integer(kind=4) function return_constant() | |
63 | return_constant = 17 | |
64 | end function | |
65 | ||
66 | character(40) function return_string() | |
67 | return_string='returned in hidden first argument' | |
68 | end function | |
69 | ||
70 | recursive function fibonacci(n) result(item) | |
71 | integer(kind=4) :: item | |
72 | integer(kind=4), intent(in) :: n | |
73 | select case (n) | |
74 | case (0:1) | |
75 | item = n | |
76 | case default | |
77 | item = fibonacci(n-1) + fibonacci(n-2) | |
78 | end select | |
79 | end function | |
80 | ||
81 | complex function complex_argument(a) | |
82 | complex, intent(in) :: a | |
83 | complex_argument = a | |
84 | end function | |
85 | ||
86 | integer(kind=4) function array_function(a) | |
87 | integer(kind=4), dimension(11) :: a | |
88 | array_function = a(ubound(a, 1, 4)) | |
89 | end function | |
90 | ||
91 | integer(kind=4) function pointer_function(int_pointer) | |
92 | integer, pointer :: int_pointer | |
93 | pointer_function = int_pointer | |
94 | end function | |
95 | ||
96 | integer(kind=4) function hidden_string_length(string) | |
97 | character*(*) :: string | |
98 | hidden_string_length = len(string) | |
99 | end function | |
100 | ||
101 | integer(kind=4) function sum_some(a, b, c) | |
102 | integer :: a, b | |
103 | integer, optional :: c | |
104 | sum_some = a + b | |
105 | if (present(c)) then | |
106 | sum_some = sum_some + c | |
107 | end if | |
108 | end function | |
109 | ||
110 | module derived_types_and_module_calls | |
111 | type cart | |
112 | integer :: x | |
113 | integer :: y | |
114 | end type | |
115 | type cart_nd | |
116 | integer :: x | |
117 | integer, allocatable :: d(:) | |
118 | end type | |
119 | type nested_cart_3d | |
120 | type(cart) :: d | |
121 | integer :: z | |
122 | end type | |
123 | contains | |
124 | type(cart) function pass_cart(c) | |
125 | type(cart) :: c | |
126 | pass_cart = c | |
127 | end function | |
128 | integer(kind=4) function pass_cart_nd(c) | |
129 | type(cart_nd) :: c | |
130 | pass_cart_nd = ubound(c%d,1,4) | |
131 | end function | |
132 | type(nested_cart_3d) function pass_nested_cart(c) | |
133 | type(nested_cart_3d) :: c | |
134 | pass_nested_cart = c | |
135 | end function | |
136 | type(cart) function build_cart(x,y) | |
137 | integer :: x, y | |
138 | build_cart%x = x | |
139 | build_cart%y = y | |
140 | end function | |
141 | end module | |
142 | ||
143 | program function_calls | |
144 | use derived_types_and_module_calls | |
145 | implicit none | |
146 | interface | |
147 | logical function no_arg() | |
148 | end function | |
149 | logical function one_arg(x) | |
150 | logical, intent(in) :: x | |
151 | end function | |
152 | integer(kind=4) function pointer_function(int_pointer) | |
153 | integer, pointer :: int_pointer | |
154 | end function | |
155 | integer(kind=4) function several_arguments(a, b, c) | |
156 | integer(kind=4), intent(in) :: a | |
157 | integer(kind=4), intent(in) :: b | |
158 | integer(kind=4), intent(in) :: c | |
159 | end function | |
160 | complex function complex_argument(a) | |
161 | complex, intent(in) :: a | |
162 | end function | |
163 | real(kind=4) function real4_argument(a) | |
164 | real(kind=4), intent(in) :: a | |
165 | end function | |
166 | integer(kind=4) function return_constant() | |
167 | end function | |
168 | character(40) function return_string() | |
169 | end function | |
170 | integer(kind=4) function one_arg_value(x) | |
171 | integer(kind=4), value :: x | |
172 | end function | |
173 | integer(kind=4) function sum_some(a, b, c) | |
174 | integer :: a, b | |
175 | integer, optional :: c | |
176 | end function | |
177 | integer(kind=4) function mix_of_scalar_arguments(a, b, c) | |
178 | integer(kind=4), intent(in) :: a | |
179 | logical(kind=4), intent(in) :: b | |
180 | real(kind=8), intent(in) :: c | |
181 | end function | |
182 | integer(kind=4) function array_function(a) | |
183 | integer(kind=4), dimension(11) :: a | |
184 | end function | |
185 | integer(kind=4) function hidden_string_length(string) | |
186 | character*(*) :: string | |
187 | end function | |
188 | end interface | |
189 | logical :: untrue, no_arg_return | |
190 | complex :: fft, fft_result | |
191 | integer(kind=4), dimension (11) :: integer_array | |
192 | real(kind=8) :: real8 | |
193 | real(kind=4) :: real4 | |
194 | integer, pointer :: int_pointer | |
195 | integer, target :: pointee, several_arguments_return | |
196 | integer(kind=4) :: integer_return | |
197 | type(cart) :: c, cout | |
198 | type(cart_nd) :: c_nd | |
199 | type(nested_cart_3d) :: nested_c | |
200 | character(40) :: returned_string, returned_string_debugger | |
201 | real8 = 3.00 | |
202 | real4 = 9.3 | |
203 | integer_array = 17 | |
204 | fft = cmplx(2.1, 3.3) | |
205 | print *, fft | |
206 | untrue = .FALSE. | |
207 | int_pointer => pointee | |
208 | pointee = 87 | |
209 | c%x = 2 | |
210 | c%y = 4 | |
211 | c_nd%x = 4 | |
212 | allocate(c_nd%d(4)) | |
213 | c_nd%d = 6 | |
214 | nested_c%z = 3 | |
215 | nested_c%d%x = 1 | |
216 | nested_c%d%y = 2 | |
217 | ! Use everything so it is not elided by the compiler. | |
218 | call no_arg_subroutine() | |
219 | no_arg_return = no_arg() .AND. one_arg(.FALSE.) | |
220 | several_arguments_return = several_arguments(1,2,3) + return_constant() | |
221 | integer_return = array_function(integer_array) | |
222 | integer_return = mix_of_scalar_arguments(2, untrue, real8) | |
223 | real4 = real4_argument(3.4) | |
224 | integer_return = pointer_function(int_pointer) | |
225 | c = pass_cart(c) | |
226 | integer_return = pass_cart_nd(c_nd) | |
227 | nested_c = pass_nested_cart(nested_c) | |
228 | integer_return = hidden_string_length('string of implicit length') | |
229 | call run(no_arg_subroutine) | |
230 | integer_return = one_arg_value(10) | |
231 | integer_return = sum_some(1,2,3) | |
232 | returned_string = return_string() | |
233 | cout = build_cart(4,5) | |
234 | fft_result = complex_argument(fft) | |
235 | print *, cout | |
236 | print *, several_arguments_return | |
237 | print *, fft_result | |
238 | print *, real4 | |
239 | print *, integer_return | |
240 | print *, returned_string_debugger | |
241 | deallocate(c_nd%d) ! post_init | |
242 | end program |