diff options
author | Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> | 2004-07-10 14:45:33 +0200 |
---|---|---|
committer | Tobias Schlüter <tobi@gcc.gnu.org> | 2004-07-10 14:45:33 +0200 |
commit | 7d76d73a576bd1cac0f6084122ed09e90f5509d3 (patch) | |
tree | 57ec2cbe9f8f2290ec632f170cb3cbc49d276643 /gcc/fortran | |
parent | 290e757a36c8d3503de812abdfbd84d85c0336e3 (diff) | |
download | gcc-7d76d73a576bd1cac0f6084122ed09e90f5509d3.zip gcc-7d76d73a576bd1cac0f6084122ed09e90f5509d3.tar.gz gcc-7d76d73a576bd1cac0f6084122ed09e90f5509d3.tar.bz2 |
expr.c (gfc_check_pointer_assign): Verify that rank of the LHS and RHS match.
* 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
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/fortran/expr.c | 59 |
2 files changed, 36 insertions, 28 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f95d64a..deb1566 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,10 @@ 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 more readable. (create_common): Additionally, make loop logic more obvious. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index e9ed270..ad9f42a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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; |