From c78a1d18a113826141c9e5bf920578691bc068c8 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 25 Apr 2012 06:25:48 +0000 Subject: 2012-04-25 Tobias Burnus PR fortran/52196 * lang.opt (Wrealloc-lhs, Wrealloc-lhs-all): New flags. * gfortran.h (gfc_option_t): Add them. * options.c (gfc_init_options, gfc_post_options, gfc_handle_option): Handle them. * invoke.texi: Document them. * trans-expr.c (realloc_lhs_warning): New function. (gfc_trans_arrayfunc_assign, alloc_scalar_allocatable_for_assignment, gfc_trans_assignment_1): Use it. 2012-04-25 Tobias Burnus PR fortran/52196 * gfortran.dg/realloc_on_assign_14.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@186806 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index cd48d5a67af..7092bc2f153 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -581,6 +581,19 @@ assign: /* End of prototype trans-class.c */ +static void +realloc_lhs_warning (bt type, bool array, locus *where) +{ + if (array && type != BT_CLASS && type != BT_DERIVED + && gfc_option.warn_realloc_lhs) + gfc_warning ("Code for reallocating the allocatable array at %L will " + "be added", where); + else if (gfc_option.warn_realloc_lhs_all) + gfc_warning ("Code for reallocating the allocatable variable at %L " + "will be added", where); +} + + static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); @@ -6479,6 +6492,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) && !(expr2->value.function.esym && expr2->value.function.esym->result->attr.allocatable)) { + realloc_lhs_warning (expr1->ts.type, true, &expr1->where); + if (!expr2->value.function.isym) { realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop); @@ -6740,6 +6755,8 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, if (!expr2 || expr2->rank) return; + realloc_lhs_warning (expr2->ts.type, false, &expr2->where); + /* Since this is a scalar lhs, we can afford to do this. That is, there is no risk of side effects being repeated. */ gfc_init_se (&lse, NULL); @@ -6988,7 +7005,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { /* F2003: Add the code for reallocation on assignment. */ if (gfc_option.flag_realloc_lhs - && is_scalar_reallocatable_lhs (expr1)) + && is_scalar_reallocatable_lhs (expr1)) alloc_scalar_allocatable_for_assignment (&block, rse.string_length, expr1, expr2); @@ -7031,8 +7048,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (gfc_option.flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1) && !gfc_expr_attr (expr1).codimension - && !gfc_is_coindexed (expr1)) + && !gfc_is_coindexed (expr1) + && expr2->rank) { + realloc_lhs_warning (expr1->ts.type, true, &expr1->where); ompws_flags &= ~OMPWS_SCALARIZER_WS; tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); if (tmp != NULL_TREE) -- cgit v1.2.1