diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 633775fc625bfce725409c8e07810b34ad50d963..47ebdce5b4b2c9c1ff9d2959ca366af2c53eaecd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2009-03-28 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/38538
+ * trans-array.c (get_elemental_fcn_charlen): Remove.
+ (get_array_charlen): New function to replace previous.
+
2009-03-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38765
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 56b4a6832718d369b2ff851ac91e2e567fb9d619..e7b52325495c78c01cc99ec13d01de57eac13ee5 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4703,47 +4703,102 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
}
-/* gfc_conv_expr_descriptor needs the character length of elemental
- functions before the function is called so that the size of the
- temporary can be obtained. The only way to do this is to convert
- the expression, mapping onto the actual arguments. */
+/* gfc_conv_expr_descriptor needs the string length an expression
+ so that the size of the temporary can be obtained. This is done
+ by adding up the string lengths of all the elements in the
+ expression. Function with non-constant expressions have their
+ string lengths mapped onto the actual arguments using the
+ interface mapping machinery in trans-expr.c. */
static void
-get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+get_array_charlen (gfc_expr *expr, gfc_se *se)
{
gfc_interface_mapping mapping;
gfc_formal_arglist *formal;
gfc_actual_arglist *arg;
gfc_se tse;
- formal = expr->symtree->n.sym->formal;
- arg = expr->value.function.actual;
- gfc_init_interface_mapping (&mapping);
-
- /* Set se = NULL in the calls to the interface mapping, to suppress any
- backend stuff. */
- for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ if (expr->ts.cl->length
+ && gfc_is_constant_expr (expr->ts.cl->length))
{
- if (!arg->expr)
- continue;
- if (formal->sym)
- gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ if (!expr->ts.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ return;
}
- gfc_init_se (&tse, NULL);
+ switch (expr->expr_type)
+ {
+ case EXPR_OP:
+ get_array_charlen (expr->value.op.op1, se);
+
+ /* For parentheses the expression ts.cl is identical. */
+ if (expr->value.op.op == INTRINSIC_PARENTHESES)
+ return;
+
+ expr->ts.cl->backend_decl =
+ gfc_create_var (gfc_charlen_type_node, "sln");
+
+ if (expr->value.op.op2)
+ {
+ get_array_charlen (expr->value.op.op2, se);
+
+ /* Add the string lengths and assign them to the expression
+ string length backend declaration. */
+ gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
+ fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+ expr->value.op.op1->ts.cl->backend_decl,
+ expr->value.op.op2->ts.cl->backend_decl));
+ }
+ else
+ gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
+ expr->value.op.op1->ts.cl->backend_decl);
+ break;
+
+ case EXPR_FUNCTION:
+ if (expr->value.function.esym == NULL
+ || expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ break;
+ }
+
+ /* Map expressions involving the dummy arguments onto the actual
+ argument expressions. */
+ gfc_init_interface_mapping (&mapping);
+ formal = expr->symtree->n.sym->formal;
+ arg = expr->value.function.actual;
+
+ /* Set se = NULL in the calls to the interface mapping, to suppress any
+ backend stuff. */
+ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ {
+ if (!arg->expr)
+ continue;
+ if (formal->sym)
+ gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ }
- /* Build the expression for the character length and convert it. */
- gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+ gfc_init_se (&tse, NULL);
- gfc_add_block_to_block (&se->pre, &tse.pre);
- gfc_add_block_to_block (&se->post, &tse.post);
- tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
- tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
- build_int_cst (gfc_charlen_type_node, 0));
- expr->ts.cl->backend_decl = tse.expr;
- gfc_free_interface_mapping (&mapping);
+ /* Build the expression for the character length and convert it. */
+ gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+
+ gfc_add_block_to_block (&se->pre, &tse.pre);
+ gfc_add_block_to_block (&se->post, &tse.post);
+ tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+ tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
+ build_int_cst (gfc_charlen_type_node, 0));
+ expr->ts.cl->backend_decl = tse.expr;
+ gfc_free_interface_mapping (&mapping);
+ break;
+
+ default:
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ break;
+ }
}
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
@@ -4879,7 +4934,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
need_tmp = 1;
if (expr->ts.type == BT_CHARACTER
&& expr->ts.cl->length->expr_type != EXPR_CONSTANT)
- get_elemental_fcn_charlen (expr, se);
+ get_array_charlen (expr, se);
info = NULL;
}
@@ -4939,8 +4994,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+ if (expr->ts.type == BT_CHARACTER
+ && !expr->ts.cl->backend_decl)
+ get_array_charlen (expr, se);
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c5018d7d5757d919a5158533f8f27ed009e83a6b..961d0d6bb1c33d8bf30cde5545cfc857e0d4e64e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-03-28 Paul Thomas <pault@gcc.gnu.org
+
+ PR fortran/38538
+ * gfortran.dg/char_result_13.f90: New test.
+
2009-03-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38765
diff --git a/gcc/testsuite/gfortran.dg/char_result_13.f90 b/gcc/testsuite/gfortran.dg/char_result_13.f90
new file mode 100644
index 0000000000000000000000000000000000000000..741d55f166a9504f47fee09066b407221a26618f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_result_13.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! Tests the fix for PR38538, where the character length for the
+! argument of 'func' was not calculated.
+!
+! Contributed by Vivek Rao <vivekrao4@yahoo.com>
+!
+module abc
+ implicit none
+contains
+ subroutine xmain (i, j)
+ integer i, j
+ call foo (func ("_"//bar (i)//"x"//bar (j)//"x"), "_abcxabx") ! original was elemental
+ call foo (nfunc("_"//bar (j)//"x"//bar (i)//"x"), "_abxabcx")
+ end subroutine xmain
+!
+ function bar (i) result(yy)
+ integer i, j, k
+ character (len = i) :: yy(2)
+ do j = 1, size (yy, 1)
+ do k = 1, i
+ yy(j)(k:k) = char (96+k)
+ end do
+ end do
+ end function bar
+!
+ elemental function func (yy) result(xy)
+ character (len = *), intent(in) :: yy
+ character (len = len (yy)) :: xy
+ xy = yy
+ end function func
+!
+ function nfunc (yy) result(xy)
+ character (len = *), intent(in) :: yy(:)
+ character (len = len (yy)) :: xy(size (yy))
+ xy = yy
+ end function nfunc
+!
+ subroutine foo(cc, teststr)
+ character (len=*), intent(in) :: cc(:)
+ character (len=*), intent(in) :: teststr
+ if (any (cc .ne. teststr)) call abort
+ end subroutine foo
+end module abc
+
+ use abc
+ call xmain(3, 2)
+end
+! { dg-final { cleanup-modules "abc" } }
+