From 8b7cec587aa4e4d38ef9a258dc39cef53f8c8482 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Mon, 5 Jan 2015 17:15:17 +0000 Subject: [PATCH] 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 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 PR fortran/47674 * gfortran.dg/realloc_on_assign_25.f90: New test. From-SVN: r219193 --- gcc/fortran/ChangeLog | 17 +++ gcc/fortran/dependency.c | 48 +++---- gcc/fortran/frontend-passes.c | 132 ++++++++++++++++++ gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/realloc_on_assign_25.f90 | 20 +++ 5 files changed, 198 insertions(+), 24 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9e0fa82479d..d5a2198b77c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2015-01-05 Thomas Koenig + + 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 Update copyright years. diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 1bb5f33dfb1..c5825b8f819 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -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 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 3d3a92a0b22..ddc982d3c52 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 976c3c9e1a4..ee90726c331 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-01-05 Thomas Koenig + + PR fortran/47674 + * gfortran.dg/realloc_on_assign_25.f90: New test. + 2015-01-05 Jakub Jelinek Update copyright years. diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90 new file mode 100644 index 00000000000..1e2a2738976 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90 @@ -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