mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-28 20:01:18 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/29389 (Statement functions are not recognized as pure when they are)

Browse Source 
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/29389
	* gfortran.dg/stfunc_6.f90: New test.

	PR fortran/33850
	* gfortran.dg/assign_10.f90: New test.

From-SVN: r130472
This commit is contained in:
Paul Thomas 2007-11-27 20:47:55 +00:00
parent 0e5a218b31
commit 908a223518
9 changed files with 218 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/fortran/ChangeLog
View File

@ -1,3 +1,32 @@
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

58
gcc/fortran/expr.c
View File

@ -3010,14 +3010,18 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
if (!expr)
return false;
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_VARIABLE:
gcc_assert (expr->symtree->n.sym);
if ((*func) (expr, sym, &f))
return true;
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
{
@ -3026,6 +3030,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
}
break;
case EXPR_VARIABLE:
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
@ -3034,7 +3039,21 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
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:
@ -3074,8 +3093,27 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
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 ();
@ -3092,6 +3130,8 @@ expr_set_symbols_referenced (gfc_expr *expr,
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;
}

55
gcc/fortran/match.c
View File

@ -3209,13 +3209,12 @@ cleanup:
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;
@ -3223,12 +3222,6 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
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;
@ -3255,49 +3248,21 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
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;
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);
}
/* Match a statement function declaration. It is so easy to match
non-statement function statements with a MATCH_ERROR as opposed to
MATCH_NO that we suppress error message in most cases. */

127
gcc/fortran/resolve.c
View File

@ -1665,6 +1665,8 @@ is_external_proc (gfc_symbol *sym)
/* 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)
@ -1676,7 +1678,7 @@ 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)
{
@ -1700,6 +1702,31 @@ pure_function (gfc_expr *e, const char **name)
}
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)
{
@ -4369,8 +4396,9 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
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)
{
@ -4552,85 +4580,20 @@ resolve_deallocate_expr (gfc_expr *e)
}
/* 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
sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym)
return true;
return false;
}
static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
{
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;
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);
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;
return gfc_traverse_expr (e, sym, sym_in_expr, 0);
}
@ -5970,14 +5933,16 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
/* 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]);
}

88
gcc/fortran/trans-decl.c
View File

@ -2893,80 +2893,26 @@ gfc_generate_contained_functions (gfc_namespace * parent)
static void
generate_local_decl (gfc_symbol *);
/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
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 false;
generate_local_decl (e->symtree->n.sym);
return false;
}
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;
/* 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
|| 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;
case REF_SUBSTRING:
generate_expr_decls (sym, ref->u.ss.start);
generate_expr_decls (sym, ref->u.ss.end);
break;
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;
}
}
}
gfc_traverse_expr (e, sym, expr_decls, 0);
}

6
gcc/fortran/trans-stmt.c
View File

@ -1523,7 +1523,8 @@ static gfc_symtree *old_symtree;
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;
@ -1544,7 +1545,8 @@ forall_restore (gfc_expr *expr,
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;

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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

28
gcc/testsuite/gfortran.dg/assign_10.f90 Normal file
View File

@ -0,0 +1,28 @@
! { 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" } }

27
gcc/testsuite/gfortran.dg/stfunc_6.f90 Normal file
View File

@ -0,0 +1,27 @@
! { 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