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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183620 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1dcbfea..675c6ee 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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