blob: c69ed86a90d467ef529386cac91f50baaa6898e7 [file] [log] [blame]
! Copyright 2019-2021 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see <http://www.gnu.org/licenses/> .
! Source code for function-calls.exp.
subroutine no_arg_subroutine()
end subroutine
logical function no_arg()
no_arg = .TRUE.
end function
subroutine run(a)
external :: a
call a()
end subroutine
logical function one_arg(x)
logical, intent(in) :: x
one_arg = x
end function
integer(kind=4) function one_arg_value(x)
integer(kind=4), value :: x
one_arg_value = x
end function
integer(kind=4) function several_arguments(a, b, c)
integer(kind=4), intent(in) :: a
integer(kind=4), intent(in) :: b
integer(kind=4), intent(in) :: c
several_arguments = a + b + c
end function
integer(kind=4) function mix_of_scalar_arguments(a, b, c)
integer(kind=4), intent(in) :: a
logical(kind=4), intent(in) :: b
real(kind=8), intent(in) :: c
mix_of_scalar_arguments = a + floor(c)
if (b) then
mix_of_scalar_arguments=mix_of_scalar_arguments+1
end if
end function
real(kind=4) function real4_argument(a)
real(kind=4), intent(in) :: a
real4_argument = a
end function
integer(kind=4) function return_constant()
return_constant = 17
end function
character(40) function return_string()
return_string='returned in hidden first argument'
end function
recursive function fibonacci(n) result(item)
integer(kind=4) :: item
integer(kind=4), intent(in) :: n
select case (n)
case (0:1)
item = n
case default
item = fibonacci(n-1) + fibonacci(n-2)
end select
end function
complex function complex_argument(a)
complex, intent(in) :: a
complex_argument = a
end function
integer(kind=4) function array_function(a)
integer(kind=4), dimension(11) :: a
array_function = a(ubound(a, 1, 4))
end function
integer(kind=4) function pointer_function(int_pointer)
integer, pointer :: int_pointer
pointer_function = int_pointer
end function
integer(kind=4) function hidden_string_length(string)
character*(*) :: string
hidden_string_length = len(string)
end function
integer(kind=4) function sum_some(a, b, c)
integer :: a, b
integer, optional :: c
sum_some = a + b
if (present(c)) then
sum_some = sum_some + c
end if
end function
module derived_types_and_module_calls
type cart
integer :: x
integer :: y
end type
type cart_nd
integer :: x
integer, allocatable :: d(:)
end type
type nested_cart_3d
type(cart) :: d
integer :: z
end type
contains
type(cart) function pass_cart(c)
type(cart) :: c
pass_cart = c
end function
integer(kind=4) function pass_cart_nd(c)
type(cart_nd) :: c
pass_cart_nd = ubound(c%d,1,4)
end function
type(nested_cart_3d) function pass_nested_cart(c)
type(nested_cart_3d) :: c
pass_nested_cart = c
end function
type(cart) function build_cart(x,y)
integer :: x, y
build_cart%x = x
build_cart%y = y
end function
end module
program function_calls
use derived_types_and_module_calls
implicit none
interface
logical function no_arg()
end function
logical function one_arg(x)
logical, intent(in) :: x
end function
integer(kind=4) function pointer_function(int_pointer)
integer, pointer :: int_pointer
end function
integer(kind=4) function several_arguments(a, b, c)
integer(kind=4), intent(in) :: a
integer(kind=4), intent(in) :: b
integer(kind=4), intent(in) :: c
end function
complex function complex_argument(a)
complex, intent(in) :: a
end function
real(kind=4) function real4_argument(a)
real(kind=4), intent(in) :: a
end function
integer(kind=4) function return_constant()
end function
character(40) function return_string()
end function
integer(kind=4) function one_arg_value(x)
integer(kind=4), value :: x
end function
integer(kind=4) function sum_some(a, b, c)
integer :: a, b
integer, optional :: c
end function
integer(kind=4) function mix_of_scalar_arguments(a, b, c)
integer(kind=4), intent(in) :: a
logical(kind=4), intent(in) :: b
real(kind=8), intent(in) :: c
end function
integer(kind=4) function array_function(a)
integer(kind=4), dimension(11) :: a
end function
integer(kind=4) function hidden_string_length(string)
character*(*) :: string
end function
end interface
logical :: untrue, no_arg_return
complex :: fft, fft_result
integer(kind=4), dimension (11) :: integer_array
real(kind=8) :: real8
real(kind=4) :: real4
integer, pointer :: int_pointer
integer, target :: pointee, several_arguments_return
integer(kind=4) :: integer_return
type(cart) :: c, cout
type(cart_nd) :: c_nd
type(nested_cart_3d) :: nested_c
character(40) :: returned_string, returned_string_debugger
real8 = 3.00
real4 = 9.3
integer_array = 17
fft = cmplx(2.1, 3.3)
print *, fft
untrue = .FALSE.
int_pointer => pointee
pointee = 87
c%x = 2
c%y = 4
c_nd%x = 4
allocate(c_nd%d(4))
c_nd%d = 6
nested_c%z = 3
nested_c%d%x = 1
nested_c%d%y = 2
! Use everything so it is not elided by the compiler.
call no_arg_subroutine()
no_arg_return = no_arg() .AND. one_arg(.FALSE.)
several_arguments_return = several_arguments(1,2,3) + return_constant()
integer_return = array_function(integer_array)
integer_return = mix_of_scalar_arguments(2, untrue, real8)
real4 = real4_argument(3.4)
integer_return = pointer_function(int_pointer)
c = pass_cart(c)
integer_return = pass_cart_nd(c_nd)
nested_c = pass_nested_cart(nested_c)
integer_return = hidden_string_length('string of implicit length')
call run(no_arg_subroutine)
integer_return = one_arg_value(10)
integer_return = sum_some(1,2,3)
returned_string = return_string()
cout = build_cart(4,5)
fft_result = complex_argument(fft)
print *, cout
print *, several_arguments_return
print *, fft_result
print *, real4
print *, integer_return
print *, returned_string_debugger
deallocate(c_nd%d) ! post_init
end program