[gfortran, committed] Obvious fix to pointer assigns

[Tobias Schlüter]

This is fallout from further investigating pr 15969: we didn't check if
the ranks of the RHS and the LHS match in a pointer assignment.

Built and tested on i686-pc-linux, committed under the obviously correct
rule. The patch is only 6 lines, but because I made it return early in
case of '=> NULL()', instead of the big if { ... }, I could move several
lines to the left.

- Tobi

Index: ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/ChangeLog,v
retrieving revision 1.108
diff -c -3 -p -r1.108 ChangeLog
*** ChangeLog   10 Jul 2004 11:21:41 -0000      1.108
--- ChangeLog   10 Jul 2004 12:43:30 -0000
***************
*** 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.
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.8
diff -c -3 -p -r1.8 expr.c
*** expr.c      29 Jun 2004 17:01:33 -0000      1.8
--- expr.c      10 Jul 2004 12:43:30 -0000
*************** gfc_check_pointer_assign (gfc_expr * lva
*** 1807,1845 ****
    /* 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 (!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;
!       }
!
!       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);
!       }
      }

    return SUCCESS;
--- 1807,1848 ----
    /* 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)
!     return SUCCESS;
!
!   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;
!     }
!
!   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 (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;