[Patch, fortran] PR33749 - Wrong evaluation of expressions in lhs of assignment statements

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

:ADDPATCH fortran:

  integer :: p(4) = (/2,4,1,3/)
  p(p) = (/(i, i = 1, 4)/)
  print *, p
end

Gives the wrong result with -m32 but the right one with -m64 because
the index expression is detected to be a function in the latter case,
thereby generating a temporary for it.  Both modes work correctly if p
is declared integer(2).  The fix is indicated by putting the index, p,
in perentheses.  That is what this patch does - all lhs vector index
expressions are put in parentheses to force the creation of a
temporary.  At the same time, I have cleaned up resolve_code a bit by
extracting the code associated with assignments into a new function.
The testcase fails in both modes, without the patch, by comparing two
identical expressions; one for integer(4) and the other for
integer(8).

Bootstraps and regtests on x86_ia64 - OK for trunk?

Paul

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.

-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

Index: /svn/trunk/gcc/fortran/resolve.c
===================================================================
*** /svn/trunk/gcc/fortran/resolve.c	(revision 129521)
--- /svn/trunk/gcc/fortran/resolve.c	(working copy)
*************** gfc_resolve_blocks (gfc_code *b, gfc_nam
*** 5958,5963 ****
--- 5958,6067 ----
  }
  
  
+ /* 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.  */
  
*************** resolve_code (gfc_code *code, gfc_namesp
*** 6075,6154 ****
  	  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;
! 		}
! 	    }
  
- 	    gfc_check_assign (code->expr, code->expr2, 1);
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
--- 6179,6187 ----
  	  if (t == FAILURE)
  	    break;
  
! 	  if (resolve_ordinary_assign (code, ns))
! 	    goto call;
  
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
Index: /svn/trunk/gcc/testsuite/gfortran.dg/assign_9.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/assign_9.f90	(revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/assign_9.f90	(revision 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
+