re PR fortran/52016 ([OOP] Polymorphism and elemental: missing diagnostic)

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

        PR fortran/52016
        * resolve.c (resolve_formal_arglist): Fix elemental
        constraint checks for polymorphic dummies.

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

        PR fortran/52016
        * gfortran.dg/elemental_args_check_5.f90: New.

From-SVN: r183620

4 files changed, 64 insertions, 4 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1dcbfea..675c6ee 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52016
+	* resolve.c (resolve_formal_arglist): Fix elemental
+	constraint checks for polymorphic dummies.
+
 2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
 	    Tobias Burnus <burnus@gcc.gnu.org>
 
@@ -24,7 +30,11 @@
 	gfc_copy_class_to_clasfc_cs, to copy to the allocated data.
 	* trans.h : Prototypes for gfc_get_class_array_ref,
 	gfc_copy_class_to_class and gfc_conv_class_to_class.
-  
+
+2012-01-25  Tobias Burnus  <burnus@net-b.de>
+
+	* resolve.c (symbol_as): Check also for attr.class_ok.
+
 2012-01-25  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51995
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b24399d..9bd5c00 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -374,21 +374,26 @@ resolve_formal_arglist (gfc_symbol *proc)
       if (gfc_elemental (proc))
 	{
 	  /* F08:C1289.  */
-	  if (sym->attr.codimension)
+	  if (sym->attr.codimension
+	      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		  && CLASS_DATA (sym)->attr.codimension))
 	    {
 	      gfc_error ("Coarray dummy argument '%s' at %L to elemental "
 			 "procedure", sym->name, &sym->declared_at);
 	      continue;
 	    }
 
-	  if (sym->as != NULL)
+	  if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+			  && CLASS_DATA (sym)->as))
 	    {
 	      gfc_error ("Argument '%s' of elemental procedure at %L must "
 			 "be scalar", sym->name, &sym->declared_at);
 	      continue;
 	    }
 
-	  if (sym->attr.allocatable)
+	  if (sym->attr.allocatable
+	      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		  && CLASS_DATA (sym)->attr.allocatable))
 	    {
 	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
 			 "have the ALLOCATABLE attribute", sym->name,
@@ -1575,6 +1580,16 @@ resolve_procedure_expression (gfc_expr* expr)
 }
 
 
+gfc_array_spec *
+symbol_as (gfc_symbol *sym)
+{
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    return CLASS_DATA (sym)->as;
+  else
+    return sym->as;
+}
+
+
 /* Resolve an actual argument list.  Most of the time, this is just
    resolving the expressions in the list.
    The exception is that we sometimes have to decide whether arguments
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index bdd2792..b3440a0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52016
+	* gfortran.dg/elemental_args_check_5.f90: New.
+
 2012-01-27  Richard Guenther  <rguenther@suse.de>
 
 	PR middle-end/51959
diff --git a/gcc/testsuite/gfortran.dg/elemental_args_check_5.f90 b/gcc/testsuite/gfortran.dg/elemental_args_check_5.f90
new file mode 100644
index 0000000..d7445c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_args_check_5.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+!
+  type t
+  end type t
+  type t2
+  end type t2
+contains
+elemental subroutine foo0(v) ! OK
+  class(t), intent(in) :: v
+end subroutine
+
+elemental subroutine foo1(w) ! { dg-error "Argument 'w' of elemental procedure at .1. cannot have the ALLOCATABLE attribute" }
+  class(t), allocatable, intent(in) :: w
+end subroutine
+
+elemental subroutine foo2(x) ! { dg-error "Argument 'x' of elemental procedure at .1. cannot have the POINTER attribute" }
+  class(t), pointer, intent(in) :: x
+end subroutine
+
+elemental subroutine foo3(y) ! { dg-error "Coarray dummy argument 'y' at .1. to elemental procedure" }
+  class(t2), intent(in) :: y[*]
+end subroutine
+
+elemental subroutine foo4(z) ! { dg-error "Argument 'z' of elemental procedure at .1. must be scalar" }
+  class(t), intent(in) :: z(:)
+end subroutine
+
+end