Skip to content

R
riscv-gcc-1
Commit c5422462 by Paul Thomas
Options

re PR fortran/33749 (Wrong evaluation of expressions in lhs of assignment statements) 

2007-10-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/33749
	* resolve.c (resolve_ordinary_assign): New function that takes
	the code to resolve an assignment from resolve_code. In
	addition, it makes a temporary of any vector index, on the
	lhs, using gfc_get_parentheses.
	(resolve_code): On EXEC_ASSIGN call the new function.

2007-10-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/33749
	* gfortran.dg/assign_9.f90: New test.

From-SVN: r129539
parent 68d9cb44
Showing with 134 additions and 73 deletions
gcc/fortran/ChangeLog
2007-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/33749
* resolve.c (resolve_ordinary_assign): New function that takes
the code to resolve an assignment from resolve_code. In
addition, it makes a temporary of any vector index, on the
lhs, using gfc_get_parentheses.
(resolve_code): On EXEC_ASSIGN call the new function.
2007-10-20 Tobias Burnus <burnus@net-b.de>
PR fortran/33818
......
gcc/fortran/resolve.c
......@@ -5958,6 +5958,110 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
}
/* Does everything to resolve an ordinary assignment. Returns true
if this is an interface asignment. */
static bool
resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
{
bool rval = false;
gfc_expr *lhs;
gfc_expr *rhs;
int llen = 0;
int rlen = 0;
int n;
gfc_ref *ref;
if (gfc_extend_assign (code, ns) == SUCCESS)
{
lhs = code->ext.actual->expr;
rhs = code->ext.actual->next->expr;
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
{
gfc_error ("Subroutine '%s' called instead of assignment at "
"%L must be PURE", code->symtree->n.sym->name,
&code->loc);
return rval;
}
/* Make a temporary rhs when there is a default initializer
and rhs is the same symbol as the lhs. */
if (rhs->expr_type == EXPR_VARIABLE
&& rhs->symtree->n.sym->ts.type == BT_DERIVED
&& has_default_initializer (rhs->symtree->n.sym->ts.derived)
&& (lhs->symtree->n.sym == rhs->symtree->n.sym))
code->ext.actual->next->expr = gfc_get_parentheses (rhs);
return true;
}
lhs = code->expr;
rhs = code->expr2;
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
if (lhs->ts.cl != NULL
&& lhs->ts.cl->length != NULL
&& lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
llen = mpz_get_si (lhs->ts.cl->length->value.integer);
if (rhs->expr_type == EXPR_CONSTANT)
rlen = rhs->value.character.length;
else if (rhs->ts.cl != NULL
&& rhs->ts.cl->length != NULL
&& rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen)
gfc_warning_now ("CHARACTER expression will be truncated "
"in assignment (%d/%d) at %L",
llen, rlen, &code->loc);
}
/* Ensure that a vector index expression for the lvalue is evaluated
to a temporary. */
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)
ref->u.ar.start[n]
= gfc_get_parentheses (ref->u.ar.start[n]);
}
}
if (gfc_pure (NULL))
{
if (gfc_impure_variable (lhs->symtree->n.sym))
{
gfc_error ("Cannot assign to variable '%s' in PURE "
"procedure at %L",
lhs->symtree->n.sym->name,
&lhs->where);
return rval;
}
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.derived->attr.pointer_comp
&& gfc_impure_variable (rhs->symtree->n.sym))
{
gfc_error ("The impure variable at %L is assigned to "
"a derived type variable with a POINTER "
"component in a PURE procedure (12.6)",
&rhs->where);
return rval;
}
}
gfc_check_assign (lhs, rhs, 1);
return false;
}
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
......@@ -6075,80 +6179,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
if (gfc_extend_assign (code, ns) == SUCCESS)
{
gfc_expr *lhs = code->ext.actual->expr;
gfc_expr *rhs = code->ext.actual->next->expr;
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
{
gfc_error ("Subroutine '%s' called instead of assignment at "
"%L must be PURE", code->symtree->n.sym->name,
&code->loc);
break;
}
/* Make a temporary rhs when there is a default initializer
and rhs is the same symbol as the lhs. */
if (rhs->expr_type == EXPR_VARIABLE
&& rhs->symtree->n.sym->ts.type == BT_DERIVED
&& has_default_initializer (rhs->symtree->n.sym->ts.derived)
&& (lhs->symtree->n.sym == rhs->symtree->n.sym))
code->ext.actual->next->expr = gfc_get_parentheses (rhs);
goto call;
}
if (code->expr->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
int llen = 0, rlen = 0;
if (code->expr->ts.cl != NULL
&& code->expr->ts.cl->length != NULL
&& code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
if (code->expr2->expr_type == EXPR_CONSTANT)
rlen = code->expr2->value.character.length;
else if (code->expr2->ts.cl != NULL
&& code->expr2->ts.cl->length != NULL
&& code->expr2->ts.cl->length->expr_type
== EXPR_CONSTANT)
rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen)
gfc_warning_now ("CHARACTER expression will be truncated "
"in assignment (%d/%d) at %L",
llen, rlen, &code->loc);
}
if (gfc_pure (NULL))
{
if (gfc_impure_variable (code->expr->symtree->n.sym))
{
gfc_error ("Cannot assign to variable '%s' in PURE "
"procedure at %L",
code->expr->symtree->n.sym->name,
&code->expr->where);
break;
}
if (code->expr->ts.type == BT_DERIVED
&& code->expr->expr_type == EXPR_VARIABLE
&& code->expr->ts.derived->attr.pointer_comp
&& gfc_impure_variable (code->expr2->symtree->n.sym))
{
gfc_error ("The impure variable at %L is assigned to "
"a derived type variable with a POINTER "
"component in a PURE procedure (12.6)",
&code->expr2->where);
break;
}
}
if (resolve_ordinary_assign (code, ns))
goto call;
gfc_check_assign (code->expr, code->expr2, 1);
break;
case EXEC_LABEL_ASSIGN:
......
gcc/testsuite/ChangeLog
2007-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/33749
* gfortran.dg/assign_9.f90: New test.
2007-10-21 Richard Sandiford <rsandifo@nildram.co.uk>
* gcc.target/mips/mips.exp (setup_mips_tests): Set mips_mips16.
gcc/testsuite/gfortran.dg/assign_9.f90 0 → 100644
! { dg-do run }
! Tests the fix for PR33749, in which one of the two assignments
! below would not produce a temporary for the index expression.
!
! Contributed by Dick Hendrickson on comp.lang.fortran,
! " Most elegant syntax for inverting a permutation?" 20071006
!
integer(4) :: p(4) = (/2,4,1,3/)
integer(8) :: q(4) = (/2,4,1,3/)
p(p) = (/(i, i = 1, 4)/)
q(q) = (/(i, i = 1, 4)/)
if (any(p .ne. q)) call abort ()
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment