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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@132689 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index aef1c79..ad70138 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+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.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e72b97b..4cee386 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/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;

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

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