Skip to content

R
riscv-gcc-1
Commit 7474dcc1 by Paul Thomas
Options

re PR fortran/70673 (ICE with module containing functions with allocatable character scalars) 

2016-06-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/70673
	* frontend-passes.c (realloc_string_callback): Add a call to
	gfc_dep_compare_expr.

2016-06-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/70673
	* gfortran.dg/pr70673.f90: New test.

From-SVN: r237358
parent 4eb27c41
Showing with 75 additions and 32 deletions
gcc/fortran/ChangeLog
2016-06-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/70673
* frontend-passes.c (realloc_string_callback): Add a call to
gfc_dep_compare_expr.
2016-06-11 Dominique d'Humieres <dominiq@lps.ens.fr> 2016-06-11 Dominique d'Humieres <dominiq@lps.ens.fr>
PR fortran/60751 PR fortran/60751
......
gcc/fortran/frontend-passes.c
...@@ -45,7 +45,7 @@ static void realloc_strings (gfc_namespace *); ...@@ -45,7 +45,7 @@ static void realloc_strings (gfc_namespace *);
static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
static int inline_matmul_assign (gfc_code **, int *, void *); static int inline_matmul_assign (gfc_code **, int *, void *);
static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
locus *, gfc_namespace *, locus *, gfc_namespace *,
char *vname=NULL); char *vname=NULL);
/* How deep we are inside an argument list. */ /* How deep we are inside an argument list. */
...@@ -108,7 +108,7 @@ static int var_num = 1; ...@@ -108,7 +108,7 @@ static int var_num = 1;
enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T }; 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. */ using create_var. */
int n_vars; int n_vars;
...@@ -142,7 +142,7 @@ gfc_run_passes (gfc_namespace *ns) ...@@ -142,7 +142,7 @@ gfc_run_passes (gfc_namespace *ns)
/* Callback for each gfc_code node invoked from check_realloc_strings. /* Callback for each gfc_code node invoked from check_realloc_strings.
For an allocatable LHS string which also appears as a variable on For an allocatable LHS string which also appears as a variable on
the RHS, replace the RHS, replace
a = a(x:y) a = a(x:y)
...@@ -175,6 +175,13 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, ...@@ -175,6 +175,13 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
if (!gfc_check_dependency (expr1, expr2, true)) if (!gfc_check_dependency (expr1, expr2, true))
return 0; 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; current_code = c;
inserted_block = NULL; inserted_block = NULL;
changed_statement = NULL; changed_statement = NULL;
...@@ -422,7 +429,7 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, ...@@ -422,7 +429,7 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
return 0; return 0;
/* We don't do character functions with unknown charlens. */ /* 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 == NULL || (*e)->ts.u.cl->length == NULL
|| (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
return 0; return 0;
...@@ -446,7 +453,7 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, ...@@ -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) if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
return 0; return 0;
/* Skip the test for pure functions if -faggressive-function-elimination /* Skip the test for pure functions if -faggressive-function-elimination
is specified. */ is specified. */
if ((*e)->value.function.esym) if ((*e)->value.function.esym)
...@@ -528,7 +535,7 @@ constant_string_length (gfc_expr *e) ...@@ -528,7 +535,7 @@ constant_string_length (gfc_expr *e)
{ {
res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
&e->where); &e->where);
mpz_add_ui (res->value.integer, value, 1); mpz_add_ui (res->value.integer, value, 1);
mpz_clear (value); mpz_clear (value);
return res; return res;
...@@ -568,7 +575,7 @@ insert_block () ...@@ -568,7 +575,7 @@ insert_block ()
/* If the statement has a label, make sure it is transferred to /* If the statement has a label, make sure it is transferred to
the newly created block. */ the newly created block. */
if ((*current_code)->here) if ((*current_code)->here)
{ {
inserted_block->here = (*current_code)->here; inserted_block->here = (*current_code)->here;
(*current_code)->here = NULL; (*current_code)->here = NULL;
...@@ -640,12 +647,12 @@ create_var (gfc_expr * e, const char *vname) ...@@ -640,12 +647,12 @@ create_var (gfc_expr * e, const char *vname)
for (i=0; i<e->rank; i++) for (i=0; i<e->rank; i++)
{ {
gfc_expr *p, *q; gfc_expr *p, *q;
p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&(e->where)); &(e->where));
mpz_set_si (p->value.integer, 1); mpz_set_si (p->value.integer, 1);
symbol->as->lower[i] = p; symbol->as->lower[i] = p;
q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
&(e->where)); &(e->where));
mpz_set (q->value.integer, e->shape[i]); mpz_set (q->value.integer, e->shape[i]);
...@@ -812,7 +819,7 @@ cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) ...@@ -812,7 +819,7 @@ cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
*walk_subtrees = 0; *walk_subtrees = 0;
return 0; return 0;
} }
return 0; return 0;
} }
...@@ -1077,8 +1084,8 @@ optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) ...@@ -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 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
&& ! (e->value.function.esym && ! (e->value.function.esym
&& (e->value.function.esym->attr.elemental && (e->value.function.esym->attr.elemental
|| e->value.function.esym->attr.allocatable || e->value.function.esym->attr.allocatable
|| e->value.function.esym->ts.type != c->expr1->ts.type || e->value.function.esym->ts.type != c->expr1->ts.type
|| e->value.function.esym->ts.kind != c->expr1->ts.kind)) || 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) ...@@ -1104,7 +1111,7 @@ optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
new_expr = gfc_copy_expr (c->expr1); new_expr = gfc_copy_expr (c->expr1);
c->expr2 = e; c->expr2 = e;
*rhs = new_expr; *rhs = new_expr;
return true; return true;
} }
...@@ -1337,7 +1344,7 @@ optimize_power (gfc_expr *e) ...@@ -1337,7 +1344,7 @@ optimize_power (gfc_expr *e)
"_internal_iand", e->where, 2, op2, "_internal_iand", e->where, 2, op2,
gfc_get_int_expr (e->ts.kind, gfc_get_int_expr (e->ts.kind,
&e->where, 1)); &e->where, 1));
ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT, ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
"_internal_ishft", e->where, 2, iand, "_internal_ishft", e->where, 2, iand,
gfc_get_int_expr (e->ts.kind, gfc_get_int_expr (e->ts.kind,
...@@ -1672,7 +1679,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) ...@@ -1672,7 +1679,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
case INTRINSIC_EQ: case INTRINSIC_EQ:
result = eq == 0; result = eq == 0;
break; break;
case INTRINSIC_GE: case INTRINSIC_GE:
result = eq >= 0; result = eq >= 0;
break; break;
...@@ -1692,7 +1699,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) ...@@ -1692,7 +1699,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
case INTRINSIC_LT: case INTRINSIC_LT:
result = eq < 0; result = eq < 0;
break; break;
default: default:
gfc_internal_error ("illegal OP in optimize_comparison"); gfc_internal_error ("illegal OP in optimize_comparison");
break; break;
...@@ -1876,12 +1883,12 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, ...@@ -1876,12 +1883,12 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
FOR_EACH_VEC_ELT (doloop_list, i, cl) FOR_EACH_VEC_ELT (doloop_list, i, cl)
{ {
gfc_symbol *do_sym; gfc_symbol *do_sym;
if (cl == NULL) if (cl == NULL)
break; break;
do_sym = cl->ext.iterator->var->symtree->n.sym; do_sym = cl->ext.iterator->var->symtree->n.sym;
if (a->expr && a->expr->symtree if (a->expr && a->expr->symtree
&& a->expr->symtree->n.sym == do_sym) && a->expr->symtree->n.sym == do_sym)
{ {
...@@ -1953,7 +1960,7 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, ...@@ -1953,7 +1960,7 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
break; break;
do_sym = dl->ext.iterator->var->symtree->n.sym; do_sym = dl->ext.iterator->var->symtree->n.sym;
if (a->expr && a->expr->symtree if (a->expr && a->expr->symtree
&& a->expr->symtree->n.sym == do_sym) && a->expr->symtree->n.sym == do_sym)
{ {
...@@ -2184,7 +2191,7 @@ runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) ...@@ -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 /* Handle matrix reallocation. Caller is responsible to insert into
the code tree. the code tree.
For the two-dimensional case, build For the two-dimensional case, build
if (allocated(c)) then if (allocated(c)) then
if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) 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, ...@@ -2277,7 +2284,7 @@ matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
/* We need two identical allocate statements in two /* We need two identical allocate statements in two
branches of the IF statement. */ branches of the IF statement. */
allocate1 = XCNEW (gfc_code); allocate1 = XCNEW (gfc_code);
allocate1->op = EXEC_ALLOCATE; allocate1->op = EXEC_ALLOCATE;
allocate1->ext.alloc.list = gfc_get_alloc (); allocate1->ext.alloc.list = gfc_get_alloc ();
...@@ -2300,7 +2307,7 @@ matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, ...@@ -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->ext.alloc.list->expr = gfc_copy_expr (c);
deallocate->next = allocate1; deallocate->next = allocate1;
deallocate->loc = c->where; deallocate->loc = c->where;
if_size_2 = XCNEW (gfc_code); if_size_2 = XCNEW (gfc_code);
if_size_2->op = EXEC_IF; if_size_2->op = EXEC_IF;
if_size_2->expr1 = cond; if_size_2->expr1 = cond;
...@@ -2580,7 +2587,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) ...@@ -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 /* Loop over the indices. For each index, create the expression
index * stride + lbound(e, dim). */ index * stride + lbound(e, dim). */
i_index = 0; i_index = 0;
for (i=0; i < ar->dimen; i++) for (i=0; i < ar->dimen; i++)
{ {
...@@ -2590,9 +2597,9 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) ...@@ -2590,9 +2597,9 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
{ {
gfc_expr *lbound, *nindex; gfc_expr *lbound, *nindex;
gfc_expr *loopvar; gfc_expr *loopvar;
loopvar = gfc_copy_expr (index[i_index]); loopvar = gfc_copy_expr (index[i_index]);
if (ar->stride[i]) if (ar->stride[i])
{ {
gfc_expr *tmp; gfc_expr *tmp;
...@@ -2610,7 +2617,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) ...@@ -2610,7 +2617,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
} }
else else
nindex = loopvar; nindex = loopvar;
/* Calculate the lower bound of the expression. */ /* Calculate the lower bound of the expression. */
if (ar->start[i]) if (ar->start[i])
{ {
...@@ -2677,12 +2684,12 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) ...@@ -2677,12 +2684,12 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
i + 1); i + 1);
gfc_free_expr (lbound_e); gfc_free_expr (lbound_e);
} }
ar->dimen_type[i] = DIMEN_ELEMENT; ar->dimen_type[i] = DIMEN_ELEMENT;
gfc_free_expr (ar->start[i]); gfc_free_expr (ar->start[i]);
ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
gfc_free_expr (ar->end[i]); gfc_free_expr (ar->end[i]);
ar->end[i] = NULL; ar->end[i] = NULL;
gfc_free_expr (ar->stride[i]); gfc_free_expr (ar->stride[i]);
...@@ -2781,7 +2788,7 @@ check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) ...@@ -2781,7 +2788,7 @@ check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
end do end do
end do end do
END BLOCK END BLOCK
*/ */
static int static int
...@@ -3213,7 +3220,7 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees, ...@@ -3213,7 +3220,7 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees,
matrix_a->where, 1, ascalar); matrix_a->where, 1, ascalar);
if (conjg_b) 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); matrix_b->where, 1, bscalar);
/* First loop comes after the zero assignment. */ /* 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, ...@@ -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 /* This goto serves as a shortcut to avoid code
duplication or a larger if or switch statement. */ duplication or a larger if or switch statement. */
goto check_omp_clauses; goto check_omp_clauses;
case EXEC_OMP_WORKSHARE: case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_PARALLEL_WORKSHARE:
......
gcc/testsuite/ChangeLog
2016-06-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/70673
* gfortran.dg/pr70673.f90: New test.
2016-06-13 Richard Biener <rguenther@suse.de> 2016-06-13 Richard Biener <rguenther@suse.de>
PR middle-end/64516 PR middle-end/64516
......
gcc/testsuite/gfortran.dg/pr70673.f90 0 → 100644
! { dg-do run }
!
! Test the fix for PR70673
!
! Contributed by David Kinniburgh <davidgkinniburgh@yahoo.co.uk>
!
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment