https://gcc.gnu.org/g:be11d636a46a330352a85dc06f804644f6a64e0b
commit r15-11042-gbe11d636a46a330352a85dc06f804644f6a64e0b Author: Harald Anlauf <[email protected]> Date: Wed Apr 1 22:28:02 2026 +0200 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. (cherry picked from commit ae9b5fc970cd4c5709e03ea90d1031b0426a4964) Diff: --- gcc/fortran/trans-expr.cc | 1 + gcc/fortran/trans-intrinsic.cc | 3 + gcc/testsuite/gfortran.dg/c_funloc_tests_10.f90 | 86 +++++++++++++++++++++++++ 3 files changed, 90 insertions(+) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 851423d55391..41c8ce534b8b 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7335,6 +7335,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 22115ef791c2..0892bb0233e8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -9679,6 +9679,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 index 000000000000..f320c8e3aea4 --- /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
