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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8616a595f8c9a5557027b172625ce3898e26a738..8d7abb2a0b4d17e82637f83b39bcac1a6f9a6f40 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2ddc2b5605e11de2be3b579cdf33db9fba67e8c0..9c4aa8a7347a1b619a30283bf02f2d84094a7343 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a0b4c2e1f7157846aa4c9eb6a32ddfa4f800f1f0..3207a0b71d85ba8c726c04c9aee3e90d6b7be2c5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/assign_9.f90 b/gcc/testsuite/gfortran.dg/assign_9.f90
new file mode 100644 (file)
index 0000000..2c2337e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assign_9.f90
@@ -0,0 +1,14 @@
+! { 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
+