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