1! Copyright 2019-2021 Free Software Foundation, Inc.
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
18subroutine no_arg_subroutine()
19end subroutine
20
21logical function no_arg()
22    no_arg = .TRUE.
23end function
24
25subroutine run(a)
26    external :: a
27    call a()
28end subroutine
29
30logical function one_arg(x)
31    logical, intent(in) :: x
32    one_arg = x
33end function
34
35integer(kind=4) function one_arg_value(x)
36    integer(kind=4), value :: x
37    one_arg_value = x
38end function
39
40integer(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
45end function
46
47integer(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
55end function
56
57real(kind=4) function real4_argument(a)
58    real(kind=4), intent(in) :: a
59    real4_argument = a
60end function
61
62integer(kind=4) function return_constant()
63    return_constant = 17
64end function
65
66character(40) function return_string()
67    return_string='returned in hidden first argument'
68end function
69
70recursive 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
79end function
80
81complex function complex_argument(a)
82    complex, intent(in) :: a
83    complex_argument = a
84end function
85
86integer(kind=4) function array_function(a)
87    integer(kind=4), dimension(11) :: a
88    array_function = a(ubound(a, 1, 4))
89end function
90
91integer(kind=4) function pointer_function(int_pointer)
92    integer, pointer :: int_pointer
93    pointer_function = int_pointer
94end function
95
96integer(kind=4) function hidden_string_length(string)
97  character*(*) :: string
98  hidden_string_length = len(string)
99end function
100
101integer(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
108end function
109
110module 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
123contains
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
141end module
142
143program 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
242end program
243