re PR fortran/47448 (Invalid check for ASSIGNMENT(=))

2011-01-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/47448
        * interface.c (gfc_check_operator_interface): Fix
        defined-assignment check.

2011-01-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/47448
        * gfortran.dg/redefined_intrinsic_assignment_2.f90: New.

From-SVN: r169229

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ad7abc5752bf01e81db8d0b7513461242f05767b..d93841351bf3386e91bd2025308c6c92df513897 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2011-01-25  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/47448
+       * interface.c (gfc_check_operator_interface): Fix
+       defined-assignment check.
+
 2011-01-21  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/47394

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b9ef8777951507c62b4de8446b8a209fc280559b..06ef3a44954fbdbe54822a89e66b4ef90836ec4a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -624,11 +624,12 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
 
       /* 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 a scalar and second an array,
+        - Types and kinds do not conform, or
         - First argument is of derived type.  */
       if (sym->formal->sym->ts.type != BT_DERIVED
          && sym->formal->sym->ts.type != BT_CLASS
-         && (r1 == 0 || r1 == r2)
+         && (r2 == 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))))

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 893b22c59dc91ae58e7d5de4102ee921ccb42f41..adad4a6294737dce54b2342923873a7c862190ea 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-25  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/47448
+       * gfortran.dg/redefined_intrinsic_assignment_2.f90: New.
+
 2011-01-25  Richard Guenther  <rguenther@suse.de>
 
        PR middle-end/47411

diff --git a/gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment_2.f90 b/gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment_2.f90
new file mode 100644 (file)
index 0000000..ba70902
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/redefined_intrinsic_assignment_2.f90
@@ -0,0 +1,68 @@
+! { dg-do compile }
+!
+! PR fortran/47448
+!
+! ASSIGNMENT(=) checks. Defined assignment is allowed if and only if
+! it does not override an intrinsic assignment.
+!
+
+module test1
+  interface assignment(=)
+     module procedure valid, valid2
+  end interface
+contains
+  ! Valid: scalar = array
+  subroutine valid (lhs,rhs)
+    integer, intent(out) ::  lhs
+    integer, intent(in) :: rhs(:)
+    lhs = rhs(1) 
+  end subroutine valid
+
+  ! Valid: array of different ranks
+  subroutine valid2 (lhs,rhs)
+    integer, intent(out) ::  lhs(:)
+    integer, intent(in) :: rhs(:,:)
+    lhs(:) = rhs(:,1) 
+  end subroutine valid2
+end module test1
+
+module test2
+  interface assignment(=)
+     module procedure invalid
+  end interface
+contains
+  ! Invalid: scalar = scalar
+  subroutine invalid (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" }
+    integer, intent(out) ::  lhs
+    integer, intent(in) :: rhs
+    lhs = rhs
+  end subroutine invalid
+end module test2
+
+module test3
+  interface assignment(=)
+     module procedure invalid2
+  end interface
+contains
+  ! Invalid: array = scalar
+  subroutine invalid2 (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" }
+    integer, intent(out) ::  lhs(:)
+    integer, intent(in) :: rhs
+    lhs(:) = rhs
+  end subroutine invalid2
+end module test3
+
+module test4
+  interface assignment(=)
+     module procedure invalid3
+  end interface
+contains
+  ! Invalid: array = array for same rank
+  subroutine invalid3 (lhs,rhs) ! { dg-error "must not redefine an INTRINSIC type assignment" }
+    integer, intent(out) ::  lhs(:)
+    integer, intent(in) :: rhs(:)
+    lhs(:) = rhs(:)
+  end subroutine invalid3
+end module test4
+
+! { dg-final { cleanup-modules "test1" } }