re PR fortran/46161 ([OOP] Invalid: Passing non-polymorphic to allocatable polymorphic dummy)

2010-10-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46161
	* interface.c (compare_allocatable): Handle polymorphic allocatables.
	(compare_parameter): Add two error messages for polymorphic dummies.

2010-10-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46161
	* gfortran.dg/class_dummy_3.f03: New.

From-SVN: r166018

gcc/fortran/ChangeLog

+2010-10-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46161
+	* interface.c (compare_allocatable): Handle polymorphic allocatables.
+	(compare_parameter): Add two error messages for polymorphic dummies.
+
 2010-10-26  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/42647

gcc/fortran/interface.c

@@ -1375,7 +1375,8 @@ compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
 {
   symbol_attribute attr;
 
-  if (formal->attr.allocatable)
+  if (formal->attr.allocatable
+      || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
     {
       attr = gfc_expr_attr (actual);
       if (!attr.allocatable)
@@ -1519,6 +1520,28 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		   gfc_typename (&formal->ts));
       return 0;
     }
+    
+  /* F2003, 12.5.2.5.  */
+  if (formal->ts.type == BT_CLASS
+      && (CLASS_DATA (formal)->attr.class_pointer
+          || CLASS_DATA (formal)->attr.allocatable))
+    {
+      if (actual->ts.type != BT_CLASS)
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+			formal->name, &actual->where);
+	  return 0;
+	}
+      if (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 "
+		       "declared type", formal->name, &actual->where);
+	  return 0;
+	}
+    }
 
   if (formal->attr.codimension)
     {

gcc/testsuite/ChangeLog

+2010-10-27  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46161
+	* gfortran.dg/class_dummy_3.f03: New.
+
 2010-10-27  H.J. Lu  <hongjiu.lu@intel.com>
 
 	* gcc.target/i386/avx-vzeroupper-1.c: Add -mtune=generic.

gcc/testsuite/gfortran.dg/class_dummy_3.f03

+! { dg-do compile }
+!
+! PR 46161: [OOP] Invalid: Passing non-polymorphic to allocatable polymorphic dummy
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  implicit none
+
+  type :: base
+  end type 
+
+  type, extends(base) :: ext
+  end type 
+
+  type(base), allocatable :: a
+  class(base), pointer :: b
+  class(ext), allocatable :: c
+  
+  call test(a)  ! { dg-error "must be polymorphic" }
+  call test(b)  ! { dg-error "must be ALLOCATABLE" }
+  call test(c)  ! { dg-error "must have the same declared type" }
+
+contains
+
+  subroutine test(arg)
+    implicit none 
+    class(base), allocatable :: arg
+  end subroutine
+
+end