Hello world,
the attached patch avoids checks for reallocation on assignment when
the same variable is on both sides of the assignment.
Regression-tested. OK for trunk?
Thomas
2013-08-29 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/52243
* trans-expr.c (is_runtime_conformable): New function.
* gfc_trans_assignment_1: Use it.
2013-08-29 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/52243
* gfortran.dg/realloc_on_assign_14.f90: Remove warning made
obsolete by patch.
* gfortran.dg/realloc_on_assign_19.f90: New test.
Index: fortran/trans-expr.c
===================================================================
--- fortran/trans-expr.c (Revision 201996)
+++ fortran/trans-expr.c (Arbeitskopie)
@@ -7738,7 +7738,103 @@ alloc_scalar_allocatable_for_assignment (stmtblock
}
}
+/* Check for assignments of the type
+ a = a + 4
+
+ to make sure we do not check for reallocation unneccessarily. */
+
+
+static bool
+is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
+{
+ gfc_actual_arglist *a;
+ gfc_expr *e1, *e2;
+
+ switch (expr2->expr_type)
+ {
+ case EXPR_VARIABLE:
+ return gfc_dep_compare_expr (expr1, expr2) == 0;
+
+ case EXPR_FUNCTION:
+ if (expr2->value.function.esym
+ && expr2->value.function.esym->attr.elemental)
+ {
+ for (a = expr2->value.function.actual; a != NULL; a = a->next)
+ {
+ e1 = a->expr;
+ if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+ return false;
+ }
+ return true;
+ }
+ else if (expr2->value.function.isym
+ && expr2->value.function.isym->elemental)
+ {
+ for (a = expr2->value.function.actual; a != NULL; a = a->next)
+ {
+ e1 = a->expr;
+ if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+ return false;
+ }
+ return true;
+ }
+
+ break;
+
+ case EXPR_OP:
+ switch (expr2->value.op.op)
+ {
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ return is_runtime_conformable (expr1, expr2->value.op.op1);
+
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_POWER:
+ case INTRINSIC_AND:
+ case INTRINSIC_OR:
+ case INTRINSIC_EQV:
+ case INTRINSIC_NEQV:
+ case INTRINSIC_EQ:
+ case INTRINSIC_NE:
+ case INTRINSIC_GT:
+ case INTRINSIC_GE:
+ case INTRINSIC_LT:
+ case INTRINSIC_LE:
+ case INTRINSIC_EQ_OS:
+ case INTRINSIC_NE_OS:
+ case INTRINSIC_GT_OS:
+ case INTRINSIC_GE_OS:
+ case INTRINSIC_LT_OS:
+ case INTRINSIC_LE_OS:
+
+ e1 = expr2->value.op.op1;
+ e2 = expr2->value.op.op2;
+
+ if (e1->rank == 0 && e2->rank > 0)
+ return is_runtime_conformable (expr1, e2);
+ else if (e1->rank > 0 && e2->rank == 0)
+ return is_runtime_conformable (expr1, e1);
+ else if (e1->rank > 0 && e2->rank > 0)
+ return is_runtime_conformable (expr1, e1)
+ && is_runtime_conformable (expr1, e2);
+ break;
+
+ default:
+ break;
+
+ }
+ default:
+ break;
+ }
+ return false;
+}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
@@ -7935,7 +8031,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr
&& gfc_is_reallocatable_lhs (expr1)
&& !gfc_expr_attr (expr1).codimension
&& !gfc_is_coindexed (expr1)
- && expr2->rank)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2))
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
Index: testsuite/gfortran.dg/realloc_on_assign_14.f90
===================================================================
--- testsuite/gfortran.dg/realloc_on_assign_14.f90 (Revision 201996)
+++ testsuite/gfortran.dg/realloc_on_assign_14.f90 (Arbeitskopie)
@@ -23,7 +23,7 @@ str = 'abc' ! { dg-warning "Code for reallocati
astr = 'abc' ! no realloc
astr = ['abc'] ! { dg-warning "Code for reallocating the allocatable array" }
a = reshape(a,shape(a)) ! { dg-warning "Code for reallocating the allocatable array" }
-r = sin(r) ! { dg-warning "Code for reallocating the allocatable array" }
+r = sin(r)
r = sin(r(1)) ! no realloc
b = sin(r(1)) ! { dg-warning "Code for reallocating the allocatable variable" }
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! PR 52243 - avoid check for reallocation when doing simple
! assignments with the same variable on both sides.
module foo
contains
elemental function ele(a)
real, intent(in) :: a
real :: ele
ele = 1./(2+a)
end function ele
subroutine bar(a)
real, dimension(:), allocatable :: a
a = a * 2.0
a = sin(a-0.3)
a = ele(a)
end subroutine bar
end module foo
! { dg-final { scan-tree-dump-times "alloc" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
