From: Paul Thomas Date: Mon, 13 Jun 2016 07:48:25 +0000 (+0000) Subject: re PR fortran/70673 (ICE with module containing functions with allocatable character... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7474dcc1fed2bbce551341798bd4d7e6e10a5aa5;p=gcc.git re PR fortran/70673 (ICE with module containing functions with allocatable character scalars) 2016-06-13 Paul Thomas PR fortran/70673 * frontend-passes.c (realloc_string_callback): Add a call to gfc_dep_compare_expr. 2016-06-13 Paul Thomas PR fortran/70673 * gfortran.dg/pr70673.f90: New test. From-SVN: r237358 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b557b34e862..998255a9bff 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-06-13 Paul Thomas + + PR fortran/70673 + * frontend-passes.c (realloc_string_callback): Add a call to + gfc_dep_compare_expr. + 2016-06-11 Dominique d'Humieres PR fortran/60751 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 37c42bb5e34..f02a52ace8b 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -45,7 +45,7 @@ static void realloc_strings (gfc_namespace *); static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); static int inline_matmul_assign (gfc_code **, int *, void *); static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, - locus *, gfc_namespace *, + locus *, gfc_namespace *, char *vname=NULL); /* How deep we are inside an argument list. */ @@ -108,7 +108,7 @@ static int var_num = 1; enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T }; -/* Keep track of the number of expressions we have inserted so far +/* Keep track of the number of expressions we have inserted so far using create_var. */ int n_vars; @@ -142,7 +142,7 @@ gfc_run_passes (gfc_namespace *ns) /* Callback for each gfc_code node invoked from check_realloc_strings. For an allocatable LHS string which also appears as a variable on - the RHS, replace + the RHS, replace a = a(x:y) @@ -175,6 +175,13 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, if (!gfc_check_dependency (expr1, expr2, true)) return 0; + /* gfc_check_dependency doesn't always pick up identical expressions. + However, eliminating the above sends the compiler into an infinite + loop on valid expressions. Without this check, the gimplifier emits + an ICE for a = a, where a is deferred character length. */ + if (!gfc_dep_compare_expr (expr1, expr2)) + return 0; + current_code = c; inserted_block = NULL; changed_statement = NULL; @@ -422,7 +429,7 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, return 0; /* We don't do character functions with unknown charlens. */ - if ((*e)->ts.type == BT_CHARACTER + if ((*e)->ts.type == BT_CHARACTER && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) return 0; @@ -446,7 +453,7 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) return 0; - + /* Skip the test for pure functions if -faggressive-function-elimination is specified. */ if ((*e)->value.function.esym) @@ -528,7 +535,7 @@ constant_string_length (gfc_expr *e) { res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, &e->where); - + mpz_add_ui (res->value.integer, value, 1); mpz_clear (value); return res; @@ -568,7 +575,7 @@ insert_block () /* If the statement has a label, make sure it is transferred to the newly created block. */ - if ((*current_code)->here) + if ((*current_code)->here) { inserted_block->here = (*current_code)->here; (*current_code)->here = NULL; @@ -640,12 +647,12 @@ create_var (gfc_expr * e, const char *vname) for (i=0; irank; i++) { gfc_expr *p, *q; - + p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &(e->where)); mpz_set_si (p->value.integer, 1); symbol->as->lower[i] = p; - + q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, &(e->where)); mpz_set (q->value.integer, e->shape[i]); @@ -812,7 +819,7 @@ cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) *walk_subtrees = 0; return 0; } - + return 0; } @@ -1077,8 +1084,8 @@ optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) } } else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 - && ! (e->value.function.esym - && (e->value.function.esym->attr.elemental + && ! (e->value.function.esym + && (e->value.function.esym->attr.elemental || e->value.function.esym->attr.allocatable || e->value.function.esym->ts.type != c->expr1->ts.type || e->value.function.esym->ts.kind != c->expr1->ts.kind)) @@ -1104,7 +1111,7 @@ optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) new_expr = gfc_copy_expr (c->expr1); c->expr2 = e; *rhs = new_expr; - + return true; } @@ -1337,7 +1344,7 @@ optimize_power (gfc_expr *e) "_internal_iand", e->where, 2, op2, gfc_get_int_expr (e->ts.kind, &e->where, 1)); - + ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT, "_internal_ishft", e->where, 2, iand, gfc_get_int_expr (e->ts.kind, @@ -1672,7 +1679,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) case INTRINSIC_EQ: result = eq == 0; break; - + case INTRINSIC_GE: result = eq >= 0; break; @@ -1692,7 +1699,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) case INTRINSIC_LT: result = eq < 0; break; - + default: gfc_internal_error ("illegal OP in optimize_comparison"); break; @@ -1876,12 +1883,12 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, FOR_EACH_VEC_ELT (doloop_list, i, cl) { gfc_symbol *do_sym; - + if (cl == NULL) break; do_sym = cl->ext.iterator->var->symtree->n.sym; - + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_sym) { @@ -1953,7 +1960,7 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, break; do_sym = dl->ext.iterator->var->symtree->n.sym; - + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_sym) { @@ -2184,7 +2191,7 @@ runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) /* Handle matrix reallocation. Caller is responsible to insert into the code tree. - For the two-dimensional case, build + For the two-dimensional case, build if (allocated(c)) then if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then @@ -2277,7 +2284,7 @@ matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, /* We need two identical allocate statements in two branches of the IF statement. */ - + allocate1 = XCNEW (gfc_code); allocate1->op = EXEC_ALLOCATE; allocate1->ext.alloc.list = gfc_get_alloc (); @@ -2300,7 +2307,7 @@ matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, deallocate->ext.alloc.list->expr = gfc_copy_expr (c); deallocate->next = allocate1; deallocate->loc = c->where; - + if_size_2 = XCNEW (gfc_code); if_size_2->op = EXEC_IF; if_size_2->expr1 = cond; @@ -2580,7 +2587,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) /* Loop over the indices. For each index, create the expression index * stride + lbound(e, dim). */ - + i_index = 0; for (i=0; i < ar->dimen; i++) { @@ -2590,9 +2597,9 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) { gfc_expr *lbound, *nindex; gfc_expr *loopvar; - - loopvar = gfc_copy_expr (index[i_index]); - + + loopvar = gfc_copy_expr (index[i_index]); + if (ar->stride[i]) { gfc_expr *tmp; @@ -2610,7 +2617,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) } else nindex = loopvar; - + /* Calculate the lower bound of the expression. */ if (ar->start[i]) { @@ -2677,12 +2684,12 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) i + 1); gfc_free_expr (lbound_e); } - + ar->dimen_type[i] = DIMEN_ELEMENT; gfc_free_expr (ar->start[i]); ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); - + gfc_free_expr (ar->end[i]); ar->end[i] = NULL; gfc_free_expr (ar->stride[i]); @@ -2781,7 +2788,7 @@ check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) end do end do END BLOCK - + */ static int @@ -3213,7 +3220,7 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees, matrix_a->where, 1, ascalar); if (conjg_b) - bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", + bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", matrix_b->where, 1, bscalar); /* First loop comes after the zero assignment. */ @@ -3586,7 +3593,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, /* This goto serves as a shortcut to avoid code duplication or a larger if or switch statement. */ goto check_omp_clauses; - + case EXEC_OMP_WORKSHARE: case EXEC_OMP_PARALLEL_WORKSHARE: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a596a54e275..506c7f77b53 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-06-13 Paul Thomas + + PR fortran/70673 + * gfortran.dg/pr70673.f90: New test. + 2016-06-13 Richard Biener PR middle-end/64516 diff --git a/gcc/testsuite/gfortran.dg/pr70673.f90 b/gcc/testsuite/gfortran.dg/pr70673.f90 new file mode 100644 index 00000000000..67856e0332e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr70673.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Test the fix for PR70673 +! +! Contributed by David Kinniburgh +! +module m +contains + subroutine s(inp) + character(*), intent(in) :: inp + character(:), allocatable :: a + a = a ! This used to ICE. + a = inp + a = a ! This used to ICE too + if ((len (a) .ne. 5) .or. (a .ne. "hello")) call abort + a = a(2:3) ! Make sure that temporary creation is not broken. + if ((len (a) .ne. 2) .or. (a .ne. "el")) call abort + deallocate (a) + a = a ! This would ICE too. + end subroutine s +end module m + + use m + call s("hello") +end