Hi all,
The attached patch from Christopher regression tested OK here.
I also compared results to other compilers. I think it is OK.
Tested on x86_64.
OK to commit to mainline and backport later after things have settled a bit.
Regards,
Jerry
---
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]>From 2d0dca791712599d549952a377d6b91cbe0eaf80 Mon Sep 17 00:00:00 2001
From: Christopher Albert <[email protected]>
Date: Tue, 31 Mar 2026 08:45:28 +0200
Subject: [PATCH] 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]>
---
gcc/fortran/trans-decl.cc | 68 +++++++++++++++++-
gcc/testsuite/gfortran.dg/pr93814.f90 | 99 +++++++++++++++++++++++++++
2 files changed, 164 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/pr93814.f90
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 0080e83fc36..3e60fb41f12 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -3129,15 +3129,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;
@@ -3184,7 +3229,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 00000000000..fb28e3f2215
--- /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
--
2.53.0
