Fortran: fix passing a procedure pointer to c_funloc [PR124652]

	PR fortran/124652

gcc/fortran/ChangeLog:

	* trans-expr.cc (gfc_conv_procedure_call): Do not clobber a
	procedure pointer intent(out) argument.
	* trans-intrinsic.cc (conv_isocbinding_function): When passing to
	C_FUNLOC a procedure pointer that is a dummy, dereference it.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c_funloc_tests_10.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d6c580f841303b8fc5d4569af3bcc29c4e30fc77..f50ddce8e82968bc74b53f99139bfefda2c3f519 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7550,6 +7550,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                  && !e->ts.u.derived->attr.alloc_comp
                                  && !e->ts.u.derived->attr.pdt_type
                                  && !gfc_is_finalizable (e->ts.u.derived, NULL)))
+                         && e->ts.type != BT_PROCEDURE
                          && !sym->attr.elemental)
                        {
                          tree var;

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 578851e1b0b474ccba62215ff0816527a5433be1..dbf645886f551647c0e688135224e15da462f2ee 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9901,6 +9901,9 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
   else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
     {
       gfc_conv_expr_reference (se, arg->expr);
+      if (arg->expr->symtree->n.sym->attr.proc_pointer
+         && arg->expr->symtree->n.sym->attr.dummy)
+       se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
       /* The code below is necessary to create a reference from the calling
         subprogram to the argument of C_FUNLOC() in the call graph.
         Please see PR 117303 for more details. */

diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_10.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_10.f90
new file mode 100644 (file)
index 0000000..f320c8e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_10.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+!
+! PR fortran/124652 - passing a procedure pointer to c_funloc
+!
+! Contributed by Damian Rouson
+
+program proc_ptr_demo
+  use iso_c_binding
+  implicit none
+
+  ! Define an interface for the type of procedure we are pointing to
+  abstract interface
+     function compute_interface(x) result(res) bind(c)
+       use iso_c_binding
+       real(c_float), intent(in), value :: x
+       real(c_float)                    :: res
+     end function compute_interface
+  end interface
+
+  ! Procedure pointers
+  procedure(compute_interface), pointer :: original_ptr => null()
+  procedure(compute_interface), pointer :: restored_ptr => null()
+  type(c_funptr) :: c_address
+  real(c_float)  :: expect
+
+  expect = square_it (5.0)
+  ! Point to our actual function
+  original_ptr => square_it
+  if (original_ptr (5.0) /= expect) stop 1
+
+  ! Convert pointers "inline"
+  c_address = c_funloc (square_it)
+  call c_f_procpointer(c_address, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 2
+  if (restored_ptr (5.0) /= expect) stop 3
+
+  c_address = c_funloc (original_ptr)
+  call c_f_procpointer (c_address, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 4
+  if (restored_ptr (5.0) /= expect) stop 5
+
+  ! Call contained subroutines to perform the C conversion logic
+  call round_trip_conversion_proc (square_it, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 6
+  if (restored_ptr (5.0) /= expect) stop 7
+
+  call round_trip_conversion_proc (original_ptr, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 8
+  if (restored_ptr (5.0) /= expect) stop 9
+
+  ! The following used to fail
+  call round_trip_conversion_ptr (square_it, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 10
+  if (restored_ptr (5.0) /= expect) stop 11
+
+  call round_trip_conversion_ptr (original_ptr, restored_ptr)
+  if (.not. associated (original_ptr, restored_ptr)) stop 12
+  if (restored_ptr (5.0) /= expect) stop 13
+
+contains
+
+  subroutine round_trip_conversion_proc (proc_in, fptr_out)
+    procedure(compute_interface)                       :: proc_in
+    procedure(compute_interface), pointer, intent(out) :: fptr_out
+    type(c_funptr) :: c_address
+!   print *, proc_in(1.0)
+    c_address = c_funloc (proc_in)
+    call c_f_procpointer (c_address, fptr_out)
+  end subroutine round_trip_conversion_proc
+
+  subroutine round_trip_conversion_ptr (fptr_in, fptr_out)
+    procedure(compute_interface), pointer, intent(in)  :: fptr_in
+    procedure(compute_interface), pointer, intent(out) :: fptr_out
+    type(c_funptr) :: c_address_s
+!   print *, fptr_in(2.0)
+    c_address_s = c_funloc (fptr_in)
+    call c_f_procpointer (c_address_s, fptr_out)
+  end subroutine round_trip_conversion_ptr
+
+  function square_it (x) result(res) bind(c)
+    real(c_float), intent(in), value :: x
+    real(c_float)                    :: res
+    res = x * x
+  end function square_it
+
+end program