re PR fortran/57217 ([OOP] Accepts invalid TBP overriding - lacking arguments check)

2013-05-28  Janus Weil  <janus@gcc.gnu.org>
	    Tobias Burnus  <burnus@net-b.de>

	PR fortran/57217
	* interface.c (check_dummy_characteristics): Symmetrize type check.


2013-05-28  Janus Weil  <janus@gcc.gnu.org>
	    Tobias Burnus  <burnus@net-b.de>

	PR fortran/57217
	* gfortran.dg/typebound_override_4.f90: New.

Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r199375

gcc/fortran/ChangeLog

+2013-05-28  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57217
+	* interface.c (check_dummy_characteristics): Symmetrize type check.
+
 2013-05-27  Bud Davis  <jmdavis@link.com>
 
 	PR fortran/50405

gcc/fortran/interface.c

@@ -1030,7 +1030,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
     return s1 == s2 ? true : false;
 
   /* Check type and rank.  */
-  if (type_must_agree && !compare_type_rank (s2, s1))
+  if (type_must_agree &&
+      (!compare_type_rank (s1, s2) || !compare_type_rank (s2, s1)))
     {
       snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
 		s1->name);

gcc/testsuite/ChangeLog

+2013-05-28  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57217
+	* gfortran.dg/typebound_override_4.f90: New.
+
 2013-05-28  Richard Biener  <rguenther@suse.de>
 
 	PR tree-optimization/57411

gcc/testsuite/gfortran.dg/typebound_override_4.f90

+! { dg-do compile }
+!
+! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
+!
+! Contributed by Salvatore Filippone <filippone.salvatore@gmail.com>
+
+module base_mod
+  implicit none
+  type base_type
+  contains
+    procedure, pass(map)  :: clone    => base_clone
+  end type
+contains
+  subroutine  base_clone(map,mapout)
+    class(base_type) :: map
+    class(base_type) :: mapout
+  end subroutine
+end module
+
+module r_mod
+  use base_mod
+  implicit none
+  type, extends(base_type) :: r_type
+  contains
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type/rank mismatch in argument" }
+  end type
+contains
+  subroutine  r_clone(map,mapout)
+    class(r_type) :: map
+    class(r_type) :: mapout
+  end subroutine
+end module
+
+! { dg-final { cleanup-modules "base_mod r_mod" } }