FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

expr.c (gfc_check_pointer_assign): Verify that rank of the LHS and RHS match.

Browse source 
* expr.c (gfc_check_pointer_assign): Verify that rank of the LHS
and RHS match. Return early if the RHS is NULL().

From-SVN: r84458
This commit is contained in:
Tobias Schlüter 2004-07-10 14:45:33 +02:00 • committed by Tobias Schlüter
parent 290e757a36
commit 7d76d73a57
2 changed files with 36 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View file

@ -1,3 +1,8 @@
2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
* expr.c (gfc_check_pointer_assign): Verify that rank of the LHS
and RHS match. Return early if the RHS is NULL().
2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
* trans-common.c: Fix whitespace issues, make variable names

59
gcc/fortran/expr.c
View file

@ -1807,39 +1807,42 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
pure variable if we're in a pure function. */
if (rvalue->expr_type != EXPR_NULL)
if (rvalue->expr_type == EXPR_NULL)
return SUCCESS;
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L",
&lvalue->where);
return FAILURE;
}
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L",
&lvalue->where);
return FAILURE;
}
if (lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
return FAILURE;
}
if (lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error
("Different kind type parameters in pointer assignment at %L",
&lvalue->where);
return FAILURE;
}
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
gfc_error ("Pointer assignment target is neither TARGET "
"nor POINTER at %L", &rvalue->where);
return FAILURE;
}
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
gfc_error
("Pointer assignment target is neither TARGET nor POINTER at "
"%L", &rvalue->where);
return FAILURE;
}
if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
{
gfc_error ("Bad target in pointer assignment in PURE "
"procedure at %L", &rvalue->where);
}
if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
{
gfc_error
("Bad target in pointer assignment in PURE procedure at %L",
&rvalue->where);
}
if (lvalue->rank != rvalue->rank)
{
gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
lvalue->rank, rvalue->rank, &rvalue->where);
return FAILURE;
}
return SUCCESS;