re PR fortran/35033 (Valid ASSIGNMENT(=) rejected)

2008-02-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35033
        * interface.c (check_operator_interface): Show better line for
        * error
        messages; fix constrains for user-defined assignment operators.
        (gfc_extend_assign): Fix constrains for user-defined assignment
        operators.

2008-02-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/35033
        * gfortran.dg/assignment_2.f90: New.

From-SVN: r132689

gcc/fortran/ChangeLog

+2008-02-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35033
+	* interface.c (check_operator_interface): Show better line for error
+	messages; fix constrains for user-defined assignment operators.
+	(gfc_extend_assign): Fix constrains for user-defined assignment
+	operators.
+
 2008-02-26  Tom Tromey  <tromey@redhat.com>
 
 	* trans-io.c (set_error_locus): Remove old location code.

gcc/fortran/interface.c

@@ -561,7 +561,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       if (sym == NULL)
 	{
 	  gfc_error ("Alternate return cannot appear in operator "
-		     "interface at %L", &intr->where);
+		     "interface at %L", &intr->sym->declared_at);
 	  return;
 	}
       if (args == 0)
@@ -591,7 +591,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       || (args == 2 && operator == INTRINSIC_NOT))
     {
       gfc_error ("Operator interface at %L has the wrong number of arguments",
-		 &intr->where);
+		 &intr->sym->declared_at);
       return;
     }
 
@@ -602,23 +602,28 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       if (!sym->attr.subroutine)
 	{
 	  gfc_error ("Assignment operator interface at %L must be "
-		     "a SUBROUTINE", &intr->where);
+		     "a SUBROUTINE", &intr->sym->declared_at);
 	  return;
 	}
       if (args != 2)
 	{
 	  gfc_error ("Assignment operator interface at %L must have "
-		     "two arguments", &intr->where);
+		     "two arguments", &intr->sym->declared_at);
 	  return;
 	}
+
+      /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
+         - First argument an array with different rank than second,
+         - Types and kinds do not conform, and
+         - First argument is of derived type.  */
       if (sym->formal->sym->ts.type != BT_DERIVED
-	  && sym->formal->next->sym->ts.type != BT_DERIVED
+	  && (r1 == 0 || r1 == r2)
 	  && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
 	      || (gfc_numeric_ts (&sym->formal->sym->ts)
 		  && gfc_numeric_ts (&sym->formal->next->sym->ts))))
 	{
 	  gfc_error ("Assignment operator interface at %L must not redefine "
-		     "an INTRINSIC type assignment", &intr->where);
+		     "an INTRINSIC type assignment", &intr->sym->declared_at);
 	  return;
 	}
     }
@@ -627,7 +632,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
       if (!sym->attr.function)
 	{
 	  gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
-		     &intr->where);
+		     &intr->sym->declared_at);
 	  return;
 	}
     }
@@ -637,21 +642,21 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
     {
       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
 	gfc_error ("First argument of defined assignment at %L must be "
-		   "INTENT(IN) or INTENT(INOUT)", &intr->where);
+		   "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
 
       if (i2 != INTENT_IN)
 	gfc_error ("Second argument of defined assignment at %L must be "
-		   "INTENT(IN)", &intr->where);
+		   "INTENT(IN)", &intr->sym->declared_at);
     }
   else
     {
       if (i1 != INTENT_IN)
 	gfc_error ("First argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->where);
+		   "INTENT(IN)", &intr->sym->declared_at);
 
       if (args == 2 && i2 != INTENT_IN)
 	gfc_error ("Second argument of operator interface at %L must be "
-		   "INTENT(IN)", &intr->where);
+		   "INTENT(IN)", &intr->sym->declared_at);
     }
 
   /* From now on, all we have to do is check that the operator definition
@@ -2654,7 +2659,8 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   rhs = c->expr2;
 
   /* Don't allow an intrinsic assignment to be replaced.  */
-  if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
+  if (lhs->ts.type != BT_DERIVED
+      && (rhs->rank == 0 || rhs->rank == lhs->rank)
       && (lhs->ts.type == rhs->ts.type
 	  || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
     return FAILURE;

gcc/testsuite/ChangeLog

+2008-02-26  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/35033
+	* gfortran.dg/assignment_2.f90: New.
+
 2008-02-26  Jason Merrill  <jason@redhat.com>
 
 	PR c++/35315

gcc/testsuite/gfortran.dg/assignment_2.f90

+! { dg-do compile }
+!
+! PR fortran/35033
+!
+! The checks for assignments were too strict.
+!
+MODULE m1
+          INTERFACE ASSIGNMENT(=)
+             SUBROUTINE s(a,b)
+                 REAL,INTENT(OUT) :: a(1,*)
+                 REAL,INTENT(IN) :: b(:)
+             END SUBROUTINE
+          END Interface
+contains
+  subroutine test1()
+          REAL,POINTER :: p(:,:),q(:)
+          CALL s(p,q) 
+          p = q
+  end subroutine test1
+end module m1
+
+MODULE m2
+          INTERFACE ASSIGNMENT(=)
+             SUBROUTINE s(a,b)
+                 REAL,INTENT(OUT),VOLATILE :: a(1,*)
+                 REAL,INTENT(IN) :: b(:)
+             END SUBROUTINE
+          END Interface
+contains
+  subroutine test1()
+          REAL,POINTER :: p(:,:),q(:)
+          CALL s(p,q) ! { dg-error "requires an assumed-shape or pointer-array dummy" }
+!TODO: The following is rightly rejected but the error message is misleading.
+! The actual reason is the mismatch between pointer array and VOLATILE
+          p = q ! { dg-error "Incompatible ranks" }
+  end subroutine test1
+end module m2
+
+MODULE m3
+          INTERFACE ASSIGNMENT(=)
+             module procedure s ! { dg-error "must not redefine an INTRINSIC type" }
+          END Interface
+contains
+             SUBROUTINE s(a,b)
+                 REAL,INTENT(OUT),VOLATILE :: a(1,*)
+                 REAL,INTENT(IN) :: b(:,:)
+             END SUBROUTINE
+end module m3
+