gdb/testsuite/gdb.fortran/mixed-lang-stack.f90

   1 ! Copyright 2020 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 2 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 module type_module
  17   use, intrinsic :: iso_c_binding, only: c_int, c_float, c_double
  18   type, bind(C) :: MyType
  19      real(c_float) :: a
  20      real(c_float) :: b
  21   end type MyType
  22 end module type_module
  23
  24 program mixed_stack_main
  25   implicit none
  26
  27   ! Set up some locals.
  28
  29   ! Call a Fortran function.
  30   call mixed_func_1a
  31
  32   write(*,*) "All done"
  33 end program mixed_stack_main
  34
  35 subroutine breakpt ()
  36   implicit none
  37   write(*,*) "Hello World"         ! Break here.
  38 end subroutine breakpt
  39
  40 subroutine mixed_func_1a()
  41   use type_module
  42   implicit none
  43
  44   TYPE(MyType) :: obj
  45   complex(kind=4) :: d
  46
  47   obj%a = 1.5
  48   obj%b = 2.5
  49   d = cmplx (4.0, 5.0)
  50
  51   ! Call a C function.
  52   call mixed_func_1b (1, 2.0, 3D0, d, "abcdef", obj)
  53 end subroutine mixed_func_1a
  54
  55 ! This subroutine is called from the Fortran code.
  56 subroutine mixed_func_1b(a, b, c, d, e, g)
  57   use type_module
  58   implicit none
  59
  60   integer :: a
  61   real(kind=4) :: b
  62   real(kind=8) :: c
  63   complex(kind=4) :: d
  64   character(len=*) :: e
  65   character(len=:), allocatable :: f
  66   TYPE(MyType) :: g
  67
  68   interface
  69      subroutine mixed_func_1c (a, b, c, d, f, g) bind(C)
  70        use, intrinsic :: iso_c_binding, only: c_int, c_float, c_double
  71        use, intrinsic :: iso_c_binding, only: c_float_complex, c_char
  72        use type_module
  73        implicit none
  74        integer(c_int), value, intent(in) :: a
  75        real(c_float), value, intent(in) :: b
  76        real(c_double), value, intent(in) :: c
  77        complex(c_float_complex), value, intent(in) :: d
  78        character(c_char), intent(in) :: f(*)
  79        TYPE(MyType) :: g
  80      end subroutine mixed_func_1c
  81   end interface
  82
  83   ! Create a copy of the string with a NULL terminator on the end.
  84   f = e//char(0)
  85
  86   ! Call a C function.
  87   call mixed_func_1c (a, b, c, d, f, g)
  88 end subroutine mixed_func_1b
  89
  90 ! This subroutine is called from the C code.
  91 subroutine mixed_func_1d(a, b, c, d, str)
  92   use, intrinsic :: iso_c_binding, only: c_int, c_float, c_double
  93   use, intrinsic :: iso_c_binding, only: c_float_complex
  94   implicit none
  95   integer(c_int) :: a
  96   real(c_float) :: b
  97   real(c_double) :: c
  98   complex(c_float_complex) :: d
  99   character(len=*) :: str
 100
 101   interface
 102      subroutine mixed_func_1e () bind(C)
 103        implicit none
 104      end subroutine mixed_func_1e
 105   end interface
 106
 107   write(*,*) a, b, c, d, str
 108
 109   ! Call a C++ function (via an extern "C" wrapper).
 110   call mixed_func_1e
 111 end subroutine mixed_func_1d
 112
 113 ! This is called from C++ code.
 114 subroutine mixed_func_1h ()
 115   call breakpt
 116 end subroutine mixed_func_1h