diff mbox

[Fortran,committed] PR 51913 - fix CLASS comparison

Message ID 4F1AD6E9.9020209@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Jan. 21, 2012, 3:16 p.m. UTC 
Dear all,

I applied the attached patch as obvious after building and regtesting it 
on x86-64-linux. (Rev. 183368.)  I will backport it to 4.6. (It's a 
4.6/4.7 regression.)

While this patch is obvious, my initial plan was to compare the class 
container names (actual->ts.u.derived->name == 
formal->ts.u.derived->name). However, that will lead to surprising error 
messages - such as that the type does not match while only an 
"allocatable" is missing. (Check ordering issue; cf. class_dummy_3.f03.)

Tobias
diff mbox

Patch

2012-01-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51913
	* interface.c (compare_parameter): Fix CLASS comparison.

2012-01-21  Tobias Burnus  <burnus@net-b.de>

	PR fortran/51913
	* gfortran.dg/class_47.f90: New.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 94f767d..9acd1fb 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1706,7 +1706,7 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 0;
     }
     
-  /* F2003, 12.5.2.5.  */
+  /* F2008, 12.5.2.5.  */
   if (formal->ts.type == BT_CLASS
       && (CLASS_DATA (formal)->attr.class_pointer
           || CLASS_DATA (formal)->attr.allocatable))
@@ -1718,8 +1718,8 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 			formal->name, &actual->where);
 	  return 0;
 	}
-      if (CLASS_DATA (actual)->ts.u.derived
-	  != CLASS_DATA (formal)->ts.u.derived)
+      if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
+				      CLASS_DATA (formal)->ts.u.derived))
 	{
 	  if (where)
 	    gfc_error ("Actual argument to '%s' at %L must have the same "
--- /dev/null	2012-01-21 09:08:15.299688263 +0100
+++ gcc/gcc/testsuite/gfortran.dg/class_47.f90	2012-01-21 14:23:38.000000000 +0100
@@ -0,0 +1,40 @@ 
+! { dg-do compile }
+!
+! PR fortran/51913
+!
+! Contributed by Alexander Tismer
+!
+MODULE m_sparseMatrix
+
+  implicit none
+  
+  type :: sparseMatrix_t
+
+  end type sparseMatrix_t
+END MODULE m_sparseMatrix
+
+!===============================================================================
+module m_subroutine
+!  USE m_sparseMatrix !< when uncommenting this line program works fine
+
+  implicit none
+
+  contains
+  subroutine test(matrix)
+    use m_sparseMatrix
+    class(sparseMatrix_t), pointer :: matrix
+  end subroutine
+end module
+
+!===============================================================================
+PROGRAM main
+  use m_subroutine
+  USE m_sparseMatrix
+  implicit none
+
+  CLASS(sparseMatrix_t), pointer :: sparseMatrix
+  
+  call test(sparseMatrix)
+END PROGRAM
+
+! { dg-final { cleanup-modules "m_sparsematrix m_subroutine" } }