https://gcc.gnu.org/g:3ac7ee541d25a96348078ec8a2c917e436a92c6b
commit r13-10305-g3ac7ee541d25a96348078ec8a2c917e436a92c6b Author: Christopher Albert <[email protected]> Date: Tue Mar 31 08:45:28 2026 +0200 fortran: Fix ICE in build_entry_thunks with CHARACTER bind(c) ENTRY [PR93814] When a CHARACTER function with bind(c) has an ENTRY also with bind(c), the entry master function returns CHARACTER by reference (void return, result passed as pointer + length arguments), but the individual bind(c) entry thunks return CHARACTER(1) by value and have no such arguments. build_entry_thunks unconditionally forwarded result-reference arguments from the thunk's own parameter list to the master call. For bind(c) CHARACTER thunks this accessed DECL_ARGUMENTS of a function with no arguments, causing a segfault. Create local temporaries for the result buffer and character length in the thunk when the master returns by reference but the thunk does not. After calling the master (which writes through the reference), load the character value from the local buffer and return it by value. PR fortran/93814 gcc/fortran/ChangeLog: * trans-decl.cc (build_entry_thunks): Create local result buffer and length temporaries for bind(c) CHARACTER entry thunks when the master returns by reference but the thunk returns by value. gcc/testsuite/ChangeLog: * gfortran.dg/pr93814.f90: New test. Signed-off-by: Christopher Albert <[email protected]> (cherry picked from commit 0ea3035ffbf1bfbc0274673fce367e9f6c6bc8e7) Diff: --- gcc/fortran/trans-decl.cc | 68 ++++++++++++++++++++++-- gcc/testsuite/gfortran.dg/pr93814.f90 | 99 +++++++++++++++++++++++++++++++++++ 2 files changed, 164 insertions(+), 3 deletions(-) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 89a59e72b8d9..3b5cd73ca97e 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -2988,15 +2988,60 @@ build_entry_thunks (gfc_namespace * ns, bool global) tmp = build_int_cst (gfc_array_index_type, el->id); vec_safe_push (args, tmp); - if (thunk_sym->attr.function) + /* When the master returns by reference, pass the result reference + and (for CHARACTER) the string length to the master call. If the + thunk itself also returns by reference these are forwarded from + its own argument list; otherwise (bind(c) CHARACTER entry) we + create local temporaries and load the value after the call. */ + tree result_ref = NULL_TREE; + if (thunk_sym->attr.function + && gfc_return_by_reference (ns->proc_name)) { - if (gfc_return_by_reference (ns->proc_name)) + if (gfc_return_by_reference (thunk_sym)) { tree ref = DECL_ARGUMENTS (current_function_decl); vec_safe_push (args, ref); if (ns->proc_name->ts.type == BT_CHARACTER) vec_safe_push (args, DECL_CHAIN (ref)); } + else + { + /* The thunk is bind(c) and returns CHARACTER by value, but + the master returns by reference. Create a local buffer + and length to pass to the master call. */ + tree chartype = gfc_get_char_type (thunk_sym->ts.kind); + tree len; + + if (thunk_sym->ts.u.cl && thunk_sym->ts.u.cl->length) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, thunk_sym->ts.u.cl->length); + gfc_add_block_to_block (&body, &se.pre); + len = se.expr; + gfc_add_block_to_block (&body, &se.post); + } + else + len = build_int_cst (gfc_charlen_type_node, 1); + + result_ref = build_decl (input_location, VAR_DECL, + get_identifier ("__entry_result"), + build_array_type (chartype, + build_range_type (gfc_array_index_type, + gfc_index_one_node, + fold_convert (gfc_array_index_type, + len)))); + DECL_ARTIFICIAL (result_ref) = 1; + TREE_USED (result_ref) = 1; + DECL_CONTEXT (result_ref) = current_function_decl; + layout_decl (result_ref, 0); + pushdecl (result_ref); + + vec_safe_push (args, + build_fold_addr_expr_loc (input_location, + result_ref)); + vec_safe_push (args, len); + } } for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal; @@ -3043,7 +3088,24 @@ build_entry_thunks (gfc_namespace * ns, bool global) vec_safe_splice (args, string_args); tmp = ns->proc_name->backend_decl; tmp = build_call_expr_loc_vec (input_location, tmp, args); - if (ns->proc_name->attr.mixed_entry_master) + if (result_ref != NULL_TREE) + { + /* The master returns by reference (void) but the bind(c) thunk + returns CHARACTER by value. Execute the master call, then + load the first character from the local buffer. */ + gfc_add_expr_to_block (&body, tmp); + tmp = build4_loc (input_location, ARRAY_REF, + TREE_TYPE (TREE_TYPE (result_ref)), + result_ref, gfc_index_one_node, + NULL_TREE, NULL_TREE); + tmp = fold_convert (TREE_TYPE (DECL_RESULT (current_function_decl)), + tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (current_function_decl)), + DECL_RESULT (current_function_decl), tmp); + tmp = build1_v (RETURN_EXPR, tmp); + } + else if (ns->proc_name->attr.mixed_entry_master) { tree union_decl, field; tree master_type = TREE_TYPE (ns->proc_name->backend_decl); diff --git a/gcc/testsuite/gfortran.dg/pr93814.f90 b/gcc/testsuite/gfortran.dg/pr93814.f90 new file mode 100644 index 000000000000..fb28e3f2215e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr93814.f90 @@ -0,0 +1,99 @@ +! { dg-do run } +! +! PR fortran/93814 - ICE in build_entry_thunks with CHARACTER ENTRY +! and bind(c). +! +! Verify that CHARACTER function results with ENTRY and bind(c) compile +! and execute correctly, covering all combinations of bind(c) on the +! function and its entries. + +! Both function and entry have bind(c). +function f1() bind(c) + character :: f1, g1 + f1 = "a" + return + entry g1() bind(c) + g1 = "b" +end + +! Only function has bind(c), entry does not. +function f2() bind(c) + character(1) :: f2, g2 + f2 = "c" + return + entry g2() + g2 = "d" +end function + +! Only entry has bind(c), function does not. +function f3() + character(1) :: f3, g3 + f3 = "e" + return + entry g3() bind(c) + g3 = "f" +end function + +! Neither function nor entry have bind(c) (baseline). +function f4() + character :: f4, g4 + f4 = "g" + return + entry g4() + g4 = "h" +end + +! Integer with bind(c) (should still work). +function f5() bind(c) + integer :: f5, g5 + f5 = 42 + return + entry g5() bind(c) + g5 = 84 +end + +program p + interface + function f1() bind(c) + character :: f1 + end + function g1() bind(c) + character :: g1 + end + function f2() bind(c) + character(1) :: f2 + end + function g2() + character(1) :: g2 + end + function f3() + character(1) :: f3 + end + function g3() bind(c) + character(1) :: g3 + end + function f4() + character :: f4 + end + function g4() + character :: g4 + end + function f5() bind(c) + integer :: f5 + end + function g5() bind(c) + integer :: g5 + end + end interface + + if (f1() /= "a") stop 1 + if (g1() /= "b") stop 2 + if (f2() /= "c") stop 3 + if (g2() /= "d") stop 4 + if (f3() /= "e") stop 5 + if (g3() /= "f") stop 6 + if (f4() /= "g") stop 7 + if (g4() /= "h") stop 8 + if (f5() /= 42) stop 9 + if (g5() /= 84) stop 10 +end
