2010-12-11 Tobias Burnus <burnus@net-b.de>

        PR fortran/46370
        * primary.c (gfc_match_varspec): Pass information about
        * codimension
        to gfc_match_array_ref also for BT_CLASS.
        * resolve.c (resolve_procedure): Correct check for C612.

2010-12-11  Tobias Burnus  <burnus@net-b.de>

        PR fortran/46370
        * gfortran.dg/coarray_14.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 03068e0..7c3fca8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2010-12-11  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/46370
+       * primary.c (gfc_match_varspec): Pass information about codimension
+       to gfc_match_array_ref also for BT_CLASS.
+       * resolve.c (resolve_procedure): Correct check for C612.
+
 2010-12-11  Mikael Morin   <mikael@gcc.gnu.org>
            Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 9632d1c..1ec677b 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1783,7 +1783,11 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       tail->type = REF_ARRAY;
 
       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
-                              equiv_flag, sym->as ? sym->as->corank : 0);
+                              equiv_flag,
+                              sym->ts.type == BT_CLASS
+                              ? (CLASS_DATA (sym)->as
+                                 ? CLASS_DATA (sym)->as->corank : 0)
+                              : (sym->as ? sym->as->corank : 0));
       if (m != MATCH_YES)
        return m;
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9d8ee23..ab49e93 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5027,13 +5027,6 @@ resolve_procedure:
     {
       gfc_ref *ref, *ref2 = NULL;
 
-      if (e->ts.type == BT_CLASS)
-       {
-         gfc_error ("Polymorphic subobject of coindexed object at %L",
-                    &e->where);
-         t = FAILURE;
-       }
-
       for (ref = e->ref; ref; ref = ref->next)
        {
          if (ref->type == REF_COMPONENT)
@@ -5046,6 +5039,14 @@ resolve_procedure:
        if (ref->type == REF_COMPONENT)
          break;
 
+      /* Expression itself is not coindexed object.  */
+      if (ref && e->ts.type == BT_CLASS)
+       {
+         gfc_error ("Polymorphic subobject of coindexed object at %L",
+                    &e->where);
+         t = FAILURE;
+       }
+
       /* Expression itself is coindexed object.  */
       if (ref == NULL)
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ed15e16..934212f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-12-11  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/46370
+       * gfortran.dg/coarray_14.f90: New.
+
 2010-12-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/46842

diff --git a/gcc/testsuite/gfortran.dg/coarray_14.f90 b/gcc/testsuite/gfortran.dg/coarray_14.f90
new file mode 100644 (file)
index 0000000..9230ad4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_14.f90
@@ -0,0 +1,55 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/46370
+!
+! Coarray checks
+!
+
+! Check for C1229: "A data-ref shall not be a polymorphic subobject of a
+! coindexed object." which applies to function and subroutine calls.
+module m
+  implicit none
+  type t
+  contains
+    procedure, nopass :: sub=>sub
+    procedure, nopass :: func=>func
+  end type t
+  type t3
+    type(t) :: nopoly
+  end type t3
+  type t2
+    class(t), allocatable :: poly
+    class(t3), allocatable :: poly2
+  end type t2
+contains
+  subroutine sub()
+  end subroutine sub
+  function func()
+    integer :: func
+  end function func
+end module m
+
+subroutine test(x)
+  use m
+  type(t2) :: x[*]
+  integer :: i
+  call x[1]%poly2%nopoly%sub() ! OK
+  i = x[1]%poly2%nopoly%func() ! OK
+  call x[1]%poly%sub() ! { dg-error "Polymorphic subobject of coindexed object" }
+  i = x[1]%poly%func() ! { dg-error "Polymorphic subobject of coindexed object" }
+end subroutine test
+
+
+! Check for C617: "... a data-ref shall not be a polymorphic subobject of a
+! coindexed object or ..." 
+! Before, the second allocate statment was failing - though it is no subobject.
+program myTest
+type t
+end type t
+class(t), allocatable :: a[:]
+ allocate (t :: a) ! { dg-error "Coarray specification required in ALLOCATE statement" }
+allocate (t :: a[*]) ! { dg-error "allocatable scalar coarrays are not yet supported" }
+end program myTest
+
+! { dg-final { cleanup-modules "m" } }