xref: /netbsd-src/external/gpl3/gdb.old/dist/gdb/testsuite/gdb.fortran/function-calls.f90 (revision 6881a4007f077b54e5f51159c52b9b25f57deb0d) 
1! Copyright 2019-2023 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    external no_arg_subroutine
202    real8 = 3.00
203    real4 = 9.3
204    integer_array = 17
205    fft = cmplx(2.1, 3.3)
206    print *, fft
207    untrue = .FALSE.
208    int_pointer => pointee
209    pointee = 87
210    c%x = 2
211    c%y = 4
212    c_nd%x = 4
213    allocate(c_nd%d(4))
214    c_nd%d = 6
215    nested_c%z = 3
216    nested_c%d%x = 1
217    nested_c%d%y = 2
218    ! Use everything so it is not elided by the compiler.
219    call no_arg_subroutine()
220    no_arg_return = no_arg() .AND. one_arg(.FALSE.)
221    several_arguments_return = several_arguments(1,2,3) + return_constant()
222    integer_return = array_function(integer_array)
223    integer_return = mix_of_scalar_arguments(2, untrue, real8)
224    real4 = real4_argument(3.4)
225    integer_return = pointer_function(int_pointer)
226    c = pass_cart(c)
227    integer_return = pass_cart_nd(c_nd)
228    nested_c = pass_nested_cart(nested_c)
229    integer_return = hidden_string_length('string of implicit length')
230    call run(no_arg_subroutine)
231    integer_return = one_arg_value(10)
232    integer_return = sum_some(1,2,3)
233    returned_string = return_string()
234    cout = build_cart(4,5)
235    fft_result = complex_argument(fft)
236    print *, cout
237    print *, several_arguments_return
238    print *, fft_result
239    print *, real4
240    print *, integer_return
241    print *, returned_string_debugger
242    deallocate(c_nd%d) ! post_init
243end program
244