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 <albert@tugraz.at>

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 03852ee9444ffd3d2d14efa5738386361137363d..4b3f75ced7101e97adff4703453b24d6dd3bf66e 100644 (file)
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -3142,15 +3142,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;
@@ -3197,7 +3242,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 (file)
index 0000000..fb28e3f
--- /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