From 7d76d73a576bd1cac0f6084122ed09e90f5509d3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Tobias=20Schl=C3=BCter?=
<tobias.schlueter@physik.uni-muenchen.de>
Date: Sat, 10 Jul 2004 14:45:33 +0200
Subject: 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
---
gcc/fortran/ChangeLog | 5 +++++
gcc/fortran/expr.c | 59 +++++++++++++++++++++++++++------------------------
2 files changed, 36 insertions(+), 28 deletions(-)
(limited to 'gcc/fortran')
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;
--
cgit v1.1