From d5f48c7c62d3d8cf8982cb29a8128e3b81335d24 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Wed, 27 Mar 2019 12:51:43 +0000 Subject: [PATCH] re PR fortran/88247 (ICE in get_array_ctor_var_strlen, at fortran/trans-array.c:2068) 2019-03-27 Paul Thomas PR fortran/88247 * expr.c (is_subref_array): Permit substrings to be detected as subref arrays. * trans-array.c (get_array_ctor_var_strlen): Obtain the length of deferred length strings. Handle substrings with a NULL end expression. (trans_array_constructor): Remove an unnecessary blank line. (gfc_conv_scalarized_array_ref): Skip to label 'done' if 'decl' is a pointer array. (get_array_charlen): If the expression is an array, convert the first element of the constructor and use its string length. Get a new charlen if necessary. (gfc_conv_expr_descriptor): Call 'get_array_charlen' for array constructor expressions. If the ss_info string length is available, use that to set the span of character arrays. * trans-expr.c (gfc_get_expr_charlen): Handle substrings * trans-stmt.c (trans_associate_var): Set the pointer array flag for variable targets and constant array constructors. Take care not to reset the string length or the span in the case of expressions that are not converted as direct by reference. 2019-03-27 Paul Thomas PR fortran/88247 * gfortran.dg/associate_47.f90: New test. From-SVN: r269962 --- gcc/fortran/ChangeLog | 23 ++++++++ gcc/fortran/expr.c | 4 +- gcc/fortran/trans-array.c | 61 +++++++++++++++++-- gcc/fortran/trans-expr.c | 16 ++++- gcc/fortran/trans-stmt.c | 6 +- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/associate_47.f90 | 69 ++++++++++++++++++++++ 7 files changed, 173 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_47.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e27e5ffcb66..e1fdb93f3d0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2019-03-27 Paul Thomas + + PR fortran/88247 + * expr.c (is_subref_array): Permit substrings to be detected + as subref arrays. + * trans-array.c (get_array_ctor_var_strlen): Obtain the length + of deferred length strings. Handle substrings with a NULL end + expression. + (trans_array_constructor): Remove an unnecessary blank line. + (gfc_conv_scalarized_array_ref): Skip to label 'done' if 'decl' + is a pointer array. + (get_array_charlen): If the expression is an array, convert the + first element of the constructor and use its string length. Get + a new charlen if necessary. + (gfc_conv_expr_descriptor): Call 'get_array_charlen' for array + constructor expressions. If the ss_info string length is + available, use that to set the span of character arrays. + * trans-expr.c (gfc_get_expr_charlen): Handle substrings + * trans-stmt.c (trans_associate_var): Set the pointer array + flag for variable targets and constant array constructors. Take + care not to reset the string length or the span in the case of + expressions that are not converted as direct by reference. + 2019-03-25 Kyrylo Tkachov * intrinsic.texi (MINLOC): Fix typo in BACK argument documentation. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 4c76f539031..f54affae18d 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -1080,8 +1080,10 @@ is_subref_array (gfc_expr * e) for (ref = e->ref; ref; ref = ref->next) { /* If we haven't seen the array reference and this is an intrinsic, - what follows cannot be a subreference array. */ + what follows cannot be a subreference array, unless there is a + substring reference. */ if (!seen_array && ref->type == REF_COMPONENT + && ref->u.c.component->ts.type != BT_CHARACTER && ref->u.c.component->ts.type != BT_CLASS && !gfc_bt_struct (ref->u.c.component->ts.type)) return false; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1379426d8e1..2bc24d95775 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2099,6 +2099,8 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) { case REF_ARRAY: /* Array references don't change the string length. */ + if (ts->deferred) + get_array_ctor_all_strlen (block, expr, len); break; case REF_COMPONENT: @@ -2107,7 +2109,8 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) break; case REF_SUBSTRING: - if (ref->u.ss.start->expr_type != EXPR_CONSTANT + if (ref->u.ss.end == NULL + || ref->u.ss.start->expr_type != EXPR_CONSTANT || ref->u.ss.end->expr_type != EXPR_CONSTANT) { /* Note that this might evaluate expr. */ @@ -2507,7 +2510,6 @@ trans_array_constructor (gfc_ss * ss, locus * where) ss_info->string_length); ss_info->string_length = gfc_evaluate_now (ss_info->string_length, &length_se.pre); - gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); gfc_add_block_to_block (&outer_loop->post, &length_se.post); } @@ -3470,6 +3472,9 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_decl; + if (decl && GFC_DECL_PTR_ARRAY_P (decl)) + goto done; + /* A pointer array component can be detected from its field decl. Fix the descriptor, mark the resulting variable decl and pass it to gfc_build_array_ref. */ @@ -3486,6 +3491,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) decl = info->descriptor; } +done: se->expr = gfc_build_array_ref (base, index, decl); } @@ -6929,6 +6935,7 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) gfc_formal_arglist *formal; gfc_actual_arglist *arg; gfc_se tse; + gfc_expr *e; if (expr->ts.u.cl->length && gfc_is_constant_expr (expr->ts.u.cl->length)) @@ -6940,6 +6947,34 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) switch (expr->expr_type) { + case EXPR_ARRAY: + + /* This is somewhat brutal. The expression for the first + element of the array is evaluated and assigned to a + new string length for the original expression. */ + e = gfc_constructor_first (expr->value.constructor)->expr; + + gfc_init_se (&tse, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&tse, e); + else + gfc_conv_expr (&tse, e); + + gfc_add_block_to_block (&se->pre, &tse.pre); + gfc_add_block_to_block (&se->post, &tse.post); + + if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl)) + { + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + expr->ts.u.cl->backend_decl = + gfc_create_var (gfc_charlen_type_node, "sln"); + } + + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + tse.string_length); + + return; + case EXPR_OP: get_array_charlen (expr->value.op.op1, se); @@ -6947,7 +6982,7 @@ get_array_charlen (gfc_expr *expr, gfc_se *se) if (expr->value.op.op == INTRINSIC_PARENTHESES) return; - expr->ts.u.cl->backend_decl = + expr->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node, "sln"); if (expr->value.op.op2) @@ -7325,7 +7360,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (need_tmp) { - if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) + if (expr->ts.type == BT_CHARACTER + && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY)) get_array_charlen (expr, se); /* Tell the scalarizer to make a temporary. */ @@ -7447,7 +7483,17 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the string_length for a character array. */ if (expr->ts.type == BT_CHARACTER) - se->string_length = gfc_get_expr_charlen (expr); + { + se->string_length = gfc_get_expr_charlen (expr); + if (VAR_P (se->string_length) + && expr->ts.u.cl->backend_decl == se->string_length) + tmp = ss_info->string_length; + else + tmp = se->string_length; + + if (expr->ts.deferred) + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); + } /* If we have an array section or are assigning make sure that the lower bound is 1. References to the full @@ -7509,7 +7555,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } /* Set the span field. */ - tmp = gfc_get_array_span (desc, expr); + if (expr->ts.type == BT_CHARACTER && ss_info->string_length) + tmp = ss_info->string_length; + else + tmp = gfc_get_array_span (desc, expr); if (tmp != NULL_TREE) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3cd2ffa722d..19fb16feebe 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1824,6 +1824,7 @@ gfc_get_expr_charlen (gfc_expr *e) { gfc_ref *r; tree length; + gfc_se se; gcc_assert (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER); @@ -1859,9 +1860,20 @@ gfc_get_expr_charlen (gfc_expr *e) /* Do nothing. */ break; + case REF_SUBSTRING: + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node); + length = se.expr; + gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); + length = fold_build2_loc (input_location, MINUS_EXPR, + gfc_charlen_type_node, + se.expr, length); + length = fold_build2_loc (input_location, PLUS_EXPR, + gfc_charlen_type_node, length, + gfc_index_one_node); + break; + default: - /* We should never got substring references here. These will be - broken down by the scalarizer. */ gcc_unreachable (); break; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 5b6625fdacb..b9966ed9318 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1707,17 +1707,19 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* If association is to an expression, evaluate it and create temporary. Otherwise, get descriptor of target for pointer assignment. */ gfc_init_se (&se, NULL); + if (sym->assoc->variable || cst_array_ctor) { se.direct_byref = 1; se.use_offset = 1; se.expr = desc; + GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } gfc_conv_expr_descriptor (&se, e); if (sym->ts.type == BT_CHARACTER - && sym->ts.deferred + && !se.direct_byref && sym->ts.deferred && !sym->attr.select_type_temporary && VAR_P (sym->ts.u.cl->backend_decl) && se.string_length != sym->ts.u.cl->backend_decl) @@ -1746,7 +1748,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* If this is a subreference array pointer associate name use the associate variable element size for the value of 'span'. */ - if (sym->attr.subref_array_pointer) + if (sym->attr.subref_array_pointer && !se.direct_byref) { gcc_assert (e->expr_type == EXPR_VARIABLE); tmp = gfc_get_array_span (se.expr, e); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ef4a55b0c3c..00eac8cde77 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-03-27 Paul Thomas + + PR fortran/88247 + * gfortran.dg/associate_47.f90: New test. + 2019-03-27 Richard Biener PR tree-optimization/89463 diff --git a/gcc/testsuite/gfortran.dg/associate_47.f90 b/gcc/testsuite/gfortran.dg/associate_47.f90 new file mode 100644 index 00000000000..085c6f38338 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_47.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! +! Test the fix for PR88247 and more besides :-) +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), allocatable :: c + character(:), dimension(:), allocatable :: d + end type + type(t), allocatable :: x + + call foo ('abcdef','ghijkl') + associate (y => [x%c(:)]) + if (y(1) .ne. 'abcdef') stop 1 + end associate + + call foo ('ghi','ghi') + associate (y => [x%c(2:)]) + if (y(1) .ne. 'hi') stop 2 + end associate + + call foo ('lmnopq','ghijkl') + associate (y => [x%c(:3)]) + if (y(1) .ne. 'lmn') stop 3 + end associate + + call foo ('abcdef','ghijkl') + associate (y => [x%c(2:4)]) + if (y(1) .ne. 'bcd') stop 4 + end associate + + call foo ('lmnopqrst','ghijklmno') + associate (y => x%d(:)) + if (len(y) .ne. 9) stop 5 + if (any (y .ne. ['lmnopqrst','ghijklmno'])) stop 5 + y(1) = 'zqrtyd' + end associate + if (x%d(1) .ne. 'zqrtyd') stop 5 + +! Substrings of arrays still do not work correctly. + call foo ('lmnopqrst','ghijklmno') + associate (y => x%d(:)(2:4)) +! if (any (y .ne. ['mno','hij'])) stop 6 + end associate + + call foo ('abcdef','ghijkl') + associate (y => [x%d(:)]) + if (len(y) .ne. 6) stop 7 + if (any (y .ne. ['abcdef','ghijkl'])) stop 7 + end associate + + call foo ('lmnopqrst','ghijklmno') + associate (y => [x%d(2:1:-1)]) + if (len(y) .ne. 9) stop 8 + if (any (y .ne. ['ghijklmno','lmnopqrst'])) stop 8 + end associate + + deallocate (x) +contains + subroutine foo (c1, c2) + character(*) :: c1, c2 + if (allocated (x)) deallocate (x) + allocate (x) + x%c = c1 + x%d = [c1, c2] + end subroutine foo +end -- 2.30.2