gdb/testsuite/gdb.fortran/function-calls.f90

   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
  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