From 5d63a35f9f1a1ec0171ae9003fba40ddc60d8f51 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 28 Mar 2009 17:08:25 +0000 Subject: [PATCH] re PR fortran/36703 (ICE (segfault) in reduce_binary0 (arith.c:1778)) 2009-02-13 Paul Thomas PR fortran/36703 PR fortran/36528 * trans-expr.c (gfc_conv_function_val): Stabilize Cray-pointer function references to ensure that a valid expression is used. (gfc_conv_function_call): Pass Cray pointers to procedures. 2009-02-13 Paul Thomas PR fortran/36528 * gfortran.dg/cray_pointers_8.f90: New test. PR fortran/36703 * gfortran.dg/cray_pointers_9.f90: New test. From-SVN: r145196 --- gcc/fortran/ChangeLog | 6 + gcc/fortran/trans-array.c | 114 ++++++++++++++----- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/char_result_13.f90 | 49 ++++++++ 4 files changed, 145 insertions(+), 29 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/char_result_13.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 633775fc625..47ebdce5b4b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2009-03-28 Paul Thomas + + PR fortran/38538 + * trans-array.c (get_elemental_fcn_charlen): Remove. + (get_array_charlen): New function to replace previous. + 2009-03-28 Paul Thomas PR fortran/38765 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 56b4a683271..e7b52325495 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); - /* Build the expression for the character length and convert it. */ - gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length); + /* For parentheses the expression ts.cl is identical. */ + if (expr->value.op.op == INTRINSIC_PARENTHESES) + return; - 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); + 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); + } + + gfc_init_se (&tse, NULL); + + /* 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 c5018d7d575..961d0d6bb1c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-03-28 Paul Thomas 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 00000000000..741d55f166a --- /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 +! +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" } } +