2007-11-27 Paul Thomas <pault@gcc.gnu.org>
+ PR fortran/29389
+ *resolve.c (resolve_ordinary_assign): Use find_sym_in_expr to
+ test if a temporary should be written for a vector subscript
+ on the lhs.
+
+ PR fortran/33850
+ * restore.c (pure_stmt_function): Add prototype and new
+ function. Calls impure_stmt_fcn.
+ (pure_function): Call it.
+ (impure_stmt_fcn): New function.
+
+ * expr.c (gfc_traverse_expr): Call *func for all expression
+ types, not just variables. Add traversal of character lengths,
+ iterators and component character lengths and arrayspecs.
+ (expr_set_symbols_referenced): Return false if not a variable.
+ * trans-stmt.c (forall_replace, forall_restore): Ditto.
+ * resolve.c (forall_index): Ditto.
+ (sym_in_expr): New function.
+ (find_sym_in_expr): Rewrite to traverse expression calling
+ sym_in_expr.
+ *trans-decl.c (expr_decls): New function.
+ (generate_expr_decls): Rewrite to traverse expression calling
+ expr_decls.
+ *match.c (check_stmt_fcn): New function.
+ (recursive_stmt_fcn): Rewrite to traverse expression calling
+ check_stmt_fcn.
+
+2007-11-27 Paul Thomas <pault@gcc.gnu.org>
+
PR fortran/33541
*interface.c (compare_actual_formal): Exclude assumed size
arrays from the possibility of scalar to array mapping.
if (!expr)
return false;
- switch (expr->expr_type)
- {
- case EXPR_VARIABLE:
- gcc_assert (expr->symtree->n.sym);
+ if ((*func) (expr, sym, &f))
+ return true;
- if ((*func) (expr, sym, &f))
- return true;
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.cl
+ && expr->ts.cl->length
+ && expr->ts.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ return true;
+ switch (expr->expr_type)
+ {
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
{
}
break;
+ case EXPR_VARIABLE:
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
case EXPR_STRUCTURE:
case EXPR_ARRAY:
for (c = expr->value.constructor; c; c = c->next)
- gfc_expr_set_symbols_referenced (c->expr);
+ {
+ if (gfc_traverse_expr (c->expr, sym, func, f))
+ return true;
+ if (c->iterator)
+ {
+ if (gfc_traverse_expr (c->iterator->var, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->start, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->end, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->step, sym, func, f))
+ return true;
+ }
+ }
break;
case EXPR_OP:
return true;
break;
- case REF_COMPONENT:
- break;
+ case REF_COMPONENT:
+ if (ref->u.c.component->ts.type == BT_CHARACTER
+ && ref->u.c.component->ts.cl
+ && ref->u.c.component->ts.cl->length
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT
+ && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ sym, func, f))
+ return true;
+
+ if (ref->u.c.component->as)
+ for (i = 0; i < ref->u.c.component->as->rank; i++)
+ {
+ if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
+ sym, func, f))
+ return true;
+ if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
+ sym, func, f))
+ return true;
+ }
+ break;
default:
gcc_unreachable ();
gfc_symbol *sym ATTRIBUTE_UNUSED,
int *f ATTRIBUTE_UNUSED)
{
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
gfc_set_sym_referenced (expr->symtree->n.sym);
return false;
}
12.5.4 requires that any variable of function that is implicitly typed
shall have that type confirmed by any subsequent type declaration. The
implicit typing is conveniently done here. */
+static bool
+recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
static bool
-recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- gfc_actual_arglist *arg;
- gfc_ref *ref;
- int i;
if (e == NULL)
return false;
switch (e->expr_type)
{
case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- {
- if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
- return true;
- }
-
if (e->symtree == NULL)
return false;
gfc_set_default_type (e->symtree->n.sym, 0, NULL);
break;
- case EXPR_OP:
- if (recursive_stmt_fcn (e->value.op.op1, sym)
- || recursive_stmt_fcn (e->value.op.op2, sym))
- return true;
- break;
-
default:
break;
}
- /* Component references do not need to be checked. */
- if (e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
- {
- if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
- || recursive_stmt_fcn (ref->u.ar.end[i], sym)
- || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
- return true;
- }
- break;
-
- case REF_SUBSTRING:
- if (recursive_stmt_fcn (ref->u.ss.start, sym)
- || recursive_stmt_fcn (ref->u.ss.end, sym))
- return true;
+ return false;
+}
- break;
- default:
- break;
- }
- }
- }
- return false;
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+ return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
}
/* Figure out if a function reference is pure or not. Also set the name
of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
+static int
+pure_stmt_function (gfc_expr *, gfc_symbol *);
static int
pure_function (gfc_expr *e, const char **name)
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
- return 1;
+ return pure_stmt_function (e, e->symtree->n.sym);
if (e->value.function.esym)
{
}
+static bool
+impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
+{
+ const char *name;
+
+ /* Don't bother recursing into other statement functions
+ since they will be checked individually for purity. */
+ if (e->expr_type != EXPR_FUNCTION
+ || !e->symtree
+ || e->symtree->n.sym == sym
+ || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+ return false;
+
+ return pure_function (e, &name) ? false : true;
+}
+
+
+static int
+pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
+{
+ return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
+}
+
+
static try
is_scalar_expr_ptr (gfc_expr *expr)
{
static bool
forall_index (gfc_expr *expr, gfc_symbol *sym, int *f)
{
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
/* A scalar assignment */
if (!expr->ref || *f == 1)
{
}
-/* Returns true if the expression e contains a reference the symbol sym. */
+/* Returns true if the expression e contains a reference to the symbol sym. */
static bool
-find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- gfc_actual_arglist *arg;
- gfc_ref *ref;
- int i;
- bool rv = false;
-
- if (e == NULL)
- return rv;
-
- switch (e->expr_type)
- {
- case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- rv = rv || find_sym_in_expr (sym, arg->expr);
- break;
-
- /* If the variable is not the same as the dependent, 'sym', and
- it is not marked as being declared and it is in the same
- namespace as 'sym', add it to the local declarations. */
- case EXPR_VARIABLE:
- if (sym == e->symtree->n.sym)
- return true;
- break;
-
- case EXPR_OP:
- rv = rv || find_sym_in_expr (sym, e->value.op.op1);
- rv = rv || find_sym_in_expr (sym, e->value.op.op2);
- break;
-
- default:
- break;
- }
-
- if (e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
- {
- rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
- rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
- rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
- }
- break;
-
- case REF_SUBSTRING:
- rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
- rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
- break;
+ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
+ return true;
- case REF_COMPONENT:
- if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->ts.cl->length);
+ return false;
+}
- if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
- {
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->as->lower[i]);
- rv = rv
- || find_sym_in_expr (sym,
- ref->u.c.component->as->upper[i]);
- }
- break;
- }
- }
- }
- return rv;
+static bool
+find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+{
+ return gfc_traverse_expr (e, sym, sym_in_expr, 0);
}
}
/* Ensure that a vector index expression for the lvalue is evaluated
- to a temporary. */
+ to a temporary if the lvalue symbol is referenced in it. */
if (lhs->rank)
{
for (ref = lhs->ref; ref; ref= ref->next)
if (ref->type == REF_ARRAY)
{
for (n = 0; n < ref->u.ar.dimen; n++)
- if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
+ && find_sym_in_expr (lhs->symtree->n.sym,
+ ref->u.ar.start[n]))
ref->u.ar.start[n]
= gfc_get_parentheses (ref->u.ar.start[n]);
}
static void
generate_local_decl (gfc_symbol *);
-static void
-generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
-{
- gfc_actual_arglist *arg;
- gfc_ref *ref;
- int i;
-
- if (e == NULL)
- return;
-
- switch (e->expr_type)
- {
- case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- generate_expr_decls (sym, arg->expr);
- break;
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
- /* If the variable is not the same as the dependent, 'sym', and
- it is not marked as being declared and it is in the same
- namespace as 'sym', add it to the local declarations. */
- case EXPR_VARIABLE:
- if (sym == e->symtree->n.sym
+static bool
+expr_decls (gfc_expr *e, gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
+{
+ if (e->expr_type != EXPR_VARIABLE
+ || sym == e->symtree->n.sym
|| e->symtree->n.sym->mark
|| e->symtree->n.sym->ns != sym->ns)
- return;
-
- generate_local_decl (e->symtree->n.sym);
- break;
-
- case EXPR_OP:
- generate_expr_decls (sym, e->value.op.op1);
- generate_expr_decls (sym, e->value.op.op2);
- break;
-
- default:
- break;
- }
-
- if (e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
- {
- generate_expr_decls (sym, ref->u.ar.start[i]);
- generate_expr_decls (sym, ref->u.ar.end[i]);
- generate_expr_decls (sym, ref->u.ar.stride[i]);
- }
- break;
+ return false;
- case REF_SUBSTRING:
- generate_expr_decls (sym, ref->u.ss.start);
- generate_expr_decls (sym, ref->u.ss.end);
- break;
+ generate_local_decl (e->symtree->n.sym);
+ return false;
+}
- case REF_COMPONENT:
- if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
-
- if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
- {
- generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
- generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
- }
- break;
- }
- }
- }
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+ gfc_traverse_expr (e, sym, expr_decls, 0);
}
static bool
forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
{
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
if (*f == 2)
*f = 1;
gfc_symbol *sym ATTRIBUTE_UNUSED,
int *f ATTRIBUTE_UNUSED)
{
- gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
if (expr->symtree == new_symtree)
expr->symtree = old_symtree;
2007-11-27 Paul Thomas <pault@gcc.gnu.org>
+ PR fortran/29389
+ * gfortran.dg/stfunc_6.f90: New test.
+
+ PR fortran/33850
+ * gfortran.dg/assign_10.f90: New test.
+
+2007-11-27 Paul Thomas <pault@gcc.gnu.org>
+
PR fortran/33541
* gfortran.dg/use_11.f90: New test.
--- /dev/null
+! { dg-do run }
+! { dg-options "-O3 -fdump-tree-original" }
+! Tests the fix for PR33850, in which one of the two assignments
+! below would produce an unnecessary temporary for the index
+! expression, following the fix for PR33749.
+!
+! Contributed by Dick Hendrickson on comp.lang.fortran,
+! " Most elegant syntax for inverting a permutation?" 20071006
+!
+ integer(4) :: p4(4) = (/2,4,1,3/)
+ integer(4) :: q4(4) = (/2,4,1,3/)
+ integer(8) :: p8(4) = (/2,4,1,3/)
+ integer(8) :: q8(4) = (/2,4,1,3/)
+ p4(q4) = (/(i, i = 1, 4)/)
+ q4(q4) = (/(i, i = 1, 4)/)
+ p8(q8) = (/(i, i = 1, 4)/)
+ q8(q8) = (/(i, i = 1, 4)/)
+ if (any(p4 .ne. q4)) call abort ()
+ if (any(p8 .ne. q8)) call abort ()
+end
+! Whichever is the default length for array indices will yield
+! parm 9 times, because a temporary is not necessary. The other
+! cases will all yield a temporary, so that atmp appears 27 times.
+! Note that it is the kind conversion that generates the temp.
+!
+! { dg-final { scan-tree-dump-times "parm" 9 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 27 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+! Tests the fix for the second bit of PR29389, in which the
+! statement function would not be recognised as not PURE
+! when it referenced a procedure that is not PURE.
+!
+! This is based on stfunc_4.f90 with the statement function made
+! impure by a reference to 'v'.
+!
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ INTEGER :: st1, i = 99, a(4), q = 6
+ st1 (i) = i * i * i
+ FORALL(i=1:4) a(i) = st1 (i)
+ FORALL(i=1:4) a(i) = u (a(i)) - a(i)** 2
+ if (any (a .ne. 0)) call abort ()
+ if (i .ne. 99) call abort ()
+contains
+ pure integer function u (x)
+ integer,intent(in) :: x
+ st2 (i) = i * v(i) ! { dg-error "non-PURE procedure" }
+ u = st2(x)
+ end function
+ integer function v (x)
+ integer,intent(in) :: x
+ v = i
+ end function
+end
OSDN Git Service
