re PR fortran/47674 (gfortran.dg/realloc_on_assign_5.f03: Segfault at run time for deferred (allocatable) string length)
2015-01-05 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/47674 * dependency.c: Update copyright years. (gfc_discard_nops): Add prototype. * dependency.c (discard_nops): Rename to gfc_discard_nops, make non-static. (gfc_discard_nops): Use gfc_discard_nops. (gfc_dep_difference): Likewise. * frontend-passes.c Update copyright years. (realloc_strings): New function. Add prototype. (gfc_run_passes): Call realloc_strings. (realloc_string_callback): New function. (create_var): Add prototype. Handle case of a scalar character variable. (optimize_trim): Do not handle allocatable variables. 2015-01-05 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/47674 * gfortran.dg/realloc_on_assign_25.f90: New test. From-SVN: r219193
This commit is contained in:
Thomas Koenig
parent
24fa8749bb
commit
8b7cec587a
5 changed files with 198 additions and 24 deletions
|
|
@ -1,3 +1,20 @@
|
|||
2015-01-05 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/47674
|
||||
* dependency.c: Update copyright years.
|
||||
(gfc_discard_nops): Add prototype.
|
||||
* dependency.c (discard_nops): Rename to gfc_discard_nops,
|
||||
make non-static.
|
||||
(gfc_discard_nops): Use gfc_discard_nops.
|
||||
(gfc_dep_difference): Likewise.
|
||||
* frontend-passes.c Update copyright years.
|
||||
(realloc_strings): New function. Add prototype.
|
||||
(gfc_run_passes): Call realloc_strings.
|
||||
(realloc_string_callback): New function.
|
||||
(create_var): Add prototype. Handle case of a
|
||||
scalar character variable.
|
||||
(optimize_trim): Do not handle allocatable variables.
|
||||
|
||||
2015-01-05 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
Update copyright years.
|
||||
|
|
|
|||
|
|
@ -243,8 +243,8 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
|
|||
/* Helper function to look through parens, unary plus and widening
|
||||
integer conversions. */
|
||||
|
||||
static gfc_expr*
|
||||
discard_nops (gfc_expr *e)
|
||||
gfc_expr *
|
||||
gfc_discard_nops (gfc_expr *e)
|
||||
{
|
||||
gfc_actual_arglist *arglist;
|
||||
|
||||
|
|
@ -297,8 +297,8 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
|
|||
if (e1 == NULL && e2 == NULL)
|
||||
return 0;
|
||||
|
||||
e1 = discard_nops (e1);
|
||||
e2 = discard_nops (e2);
|
||||
e1 = gfc_discard_nops (e1);
|
||||
e2 = gfc_discard_nops (e2);
|
||||
|
||||
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
|
||||
{
|
||||
|
|
@ -515,8 +515,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
|
||||
return false;
|
||||
|
||||
e1 = discard_nops (e1);
|
||||
e2 = discard_nops (e2);
|
||||
e1 = gfc_discard_nops (e1);
|
||||
e2 = gfc_discard_nops (e2);
|
||||
|
||||
/* Inizialize tentatively, clear if we don't return anything. */
|
||||
mpz_init (*result);
|
||||
|
|
@ -531,8 +531,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
|
||||
{
|
||||
e1_op1 = discard_nops (e1->value.op.op1);
|
||||
e1_op2 = discard_nops (e1->value.op.op2);
|
||||
e1_op1 = gfc_discard_nops (e1->value.op.op1);
|
||||
e1_op2 = gfc_discard_nops (e1->value.op.op2);
|
||||
|
||||
/* Case 2: (X + c1) - X = c1. */
|
||||
if (e1_op2->expr_type == EXPR_CONSTANT
|
||||
|
|
@ -552,8 +552,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
if (e1_op2->expr_type == EXPR_CONSTANT)
|
||||
{
|
||||
|
|
@ -597,8 +597,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
if (e1_op2->expr_type == EXPR_CONSTANT)
|
||||
{
|
||||
|
|
@ -627,8 +627,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
|
||||
{
|
||||
e1_op1 = discard_nops (e1->value.op.op1);
|
||||
e1_op2 = discard_nops (e1->value.op.op2);
|
||||
e1_op1 = gfc_discard_nops (e1->value.op.op1);
|
||||
e1_op2 = gfc_discard_nops (e1->value.op.op2);
|
||||
|
||||
if (e1_op2->expr_type == EXPR_CONSTANT)
|
||||
{
|
||||
|
|
@ -642,8 +642,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
/* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
|
||||
if (e2_op2->expr_type == EXPR_CONSTANT
|
||||
|
|
@ -668,8 +668,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
/* Case 13: (X - c1) - (X - c2) = c2 - c1. */
|
||||
if (e2_op2->expr_type == EXPR_CONSTANT
|
||||
|
|
@ -685,8 +685,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
{
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
/* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
|
||||
if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
|
||||
|
|
@ -702,8 +702,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
/* Case 15: X - (X + c2) = -c2. */
|
||||
if (e2_op2->expr_type == EXPR_CONSTANT
|
||||
|
|
@ -723,8 +723,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
|
|||
|
||||
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
|
||||
{
|
||||
e2_op1 = discard_nops (e2->value.op.op1);
|
||||
e2_op2 = discard_nops (e2->value.op.op2);
|
||||
e2_op1 = gfc_discard_nops (e2->value.op.op1);
|
||||
e2_op2 = gfc_discard_nops (e2->value.op.op2);
|
||||
|
||||
/* Case 17: X - (X - c2) = c2. */
|
||||
if (e2_op2->expr_type == EXPR_CONSTANT
|
||||
|
|
|
|||
|
|
@ -42,6 +42,8 @@ static bool is_empty_string (gfc_expr *e);
|
|||
static void doloop_warn (gfc_namespace *);
|
||||
static void optimize_reduction (gfc_namespace *);
|
||||
static int callback_reduction (gfc_expr **, int *, void *);
|
||||
static void realloc_strings (gfc_namespace *);
|
||||
static gfc_expr *create_var (gfc_expr *);
|
||||
|
||||
/* How deep we are inside an argument list. */
|
||||
|
||||
|
|
@ -113,6 +115,51 @@ gfc_run_passes (gfc_namespace *ns)
|
|||
|
||||
expr_array.release ();
|
||||
}
|
||||
|
||||
if (flag_realloc_lhs)
|
||||
realloc_strings (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
|
||||
|
||||
a = a(x:y)
|
||||
|
||||
with
|
||||
|
||||
tmp = a(x:y)
|
||||
a = tmp
|
||||
*/
|
||||
|
||||
static int
|
||||
realloc_string_callback (gfc_code **c, int *walk_subtrees,
|
||||
void *data ATTRIBUTE_UNUSED)
|
||||
{
|
||||
gfc_expr *expr1, *expr2;
|
||||
gfc_code *co = *c;
|
||||
gfc_expr *n;
|
||||
|
||||
*walk_subtrees = 0;
|
||||
if (co->op != EXEC_ASSIGN)
|
||||
return 0;
|
||||
|
||||
expr1 = co->expr1;
|
||||
if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0
|
||||
|| !expr1->symtree->n.sym->attr.allocatable)
|
||||
return 0;
|
||||
|
||||
expr2 = gfc_discard_nops (co->expr2);
|
||||
if (expr2->expr_type != EXPR_VARIABLE)
|
||||
return 0;
|
||||
|
||||
if (!gfc_check_dependency (expr1, expr2, true))
|
||||
return 0;
|
||||
|
||||
current_code = c;
|
||||
n = create_var (expr2);
|
||||
co->expr2 = n;
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Callback for each gfc_code node invoked through gfc_code_walker
|
||||
|
|
@ -430,6 +477,52 @@ is_fe_temp (gfc_expr *e)
|
|||
return e->symtree->n.sym->attr.fe_temp;
|
||||
}
|
||||
|
||||
/* Determine the length of a string, if it can be evaluated as a constant
|
||||
expression. Return a newly allocated gfc_expr or NULL on failure.
|
||||
If the user specified a substring which is potentially longer than
|
||||
the string itself, the string will be padded with spaces, which
|
||||
is harmless. */
|
||||
|
||||
static gfc_expr *
|
||||
constant_string_length (gfc_expr *e)
|
||||
{
|
||||
|
||||
gfc_expr *length;
|
||||
gfc_ref *ref;
|
||||
gfc_expr *res;
|
||||
mpz_t value;
|
||||
|
||||
if (e->ts.u.cl)
|
||||
{
|
||||
length = e->ts.u.cl->length;
|
||||
if (length && length->expr_type == EXPR_CONSTANT)
|
||||
return gfc_copy_expr(length);
|
||||
}
|
||||
|
||||
/* Return length of substring, if constant. */
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
{
|
||||
if (ref->type == REF_SUBSTRING
|
||||
&& gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
|
||||
{
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
/* Return length of char symbol, if constant. */
|
||||
|
||||
if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length
|
||||
&& e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
||||
return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
|
||||
|
||||
return NULL;
|
||||
|
||||
}
|
||||
|
||||
/* Returns a new expression (a variable) to be used in place of the old one,
|
||||
with an assignment statement before the current statement to set
|
||||
|
|
@ -525,6 +618,20 @@ create_var (gfc_expr * e)
|
|||
}
|
||||
}
|
||||
|
||||
if (e->ts.type == BT_CHARACTER && e->rank == 0)
|
||||
{
|
||||
gfc_expr *length;
|
||||
|
||||
length = constant_string_length (e);
|
||||
if (length)
|
||||
{
|
||||
symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
|
||||
symbol->ts.u.cl->length = length;
|
||||
}
|
||||
else
|
||||
symbol->attr.allocatable = 1;
|
||||
}
|
||||
|
||||
symbol->attr.flavor = FL_VARIABLE;
|
||||
symbol->attr.referenced = 1;
|
||||
symbol->attr.dimension = e->rank > 0;
|
||||
|
|
@ -849,6 +956,26 @@ optimize_namespace (gfc_namespace *ns)
|
|||
}
|
||||
}
|
||||
|
||||
/* Handle dependencies for allocatable strings which potentially redefine
|
||||
themselves in an assignment. */
|
||||
|
||||
static void
|
||||
realloc_strings (gfc_namespace *ns)
|
||||
{
|
||||
current_ns = ns;
|
||||
gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
|
||||
|
||||
for (ns = ns->contained; ns; ns = ns->sibling)
|
||||
{
|
||||
if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
|
||||
{
|
||||
// current_ns = ns;
|
||||
realloc_strings (ns);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
static void
|
||||
optimize_reduction (gfc_namespace *ns)
|
||||
{
|
||||
|
|
@ -1567,6 +1694,11 @@ optimize_trim (gfc_expr *e)
|
|||
if (a->expr_type != EXPR_VARIABLE)
|
||||
return false;
|
||||
|
||||
/* This would pessimize the idiom a = trim(a) for reallocatable strings. */
|
||||
|
||||
if (a->symtree->n.sym->attr.allocatable)
|
||||
return false;
|
||||
|
||||
/* Follow all references to find the correct place to put the newly
|
||||
created reference. FIXME: Also handle substring references and
|
||||
array references. Array references cause strange regressions at
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2015-01-05 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/47674
|
||||
* gfortran.dg/realloc_on_assign_25.f90: New test.
|
||||
|
||||
2015-01-05 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
Update copyright years.
|
||||
|
|
|
|||
20
gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90
Normal file
20
gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
! { dg-do run }
|
||||
! PR 47674 - this would segfault if MALLOC_PERTURB is set.
|
||||
! This checks a code path where it is not possible to determine
|
||||
! the length of the string at compile time.
|
||||
!
|
||||
program main
|
||||
implicit none
|
||||
character(:), allocatable :: a
|
||||
integer :: m, n
|
||||
a = 'a'
|
||||
if (a .ne. 'a') call abort
|
||||
a = a // 'x'
|
||||
if (a .ne. 'ax') call abort
|
||||
if (len (a) .ne. 2) call abort
|
||||
n = 2
|
||||
m = 2
|
||||
a = a(m:n)
|
||||
if (a .ne. 'x') call abort
|
||||
if (len (a) .ne. 1) call abort
|
||||
end program main
|
||||
Loading…
Add table
Reference in a new issue