expr.c (gfc_is_coarray): New function.

2011-07-19  Tobias Burnus  <burnus@net-b.de>

        * expr.c (gfc_is_coarray): New function.
        * gfortran.h (gfc_is_coarray): New prototype.
        * interface.c (compare_parameter): Use it.

2011-07-19  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_args_1.f90: New.
        * gfortran.dg/coarray_args_2.f90: New.

From-SVN: r176467

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b3019f3571e4c9753d487d3117f2012ce5c6190b..bf911123455a3c10071688566b0616f25e66eb78 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2011-07-19  Tobias Burnus  <burnus@net-b.de>
+
+       * expr.c (gfc_is_coarray): New function.
+       * gfortran.h (gfc_is_coarray): New prototype.
+       * interface.c (compare_parameter): Use it.
+
 2011-07-19  Richard Guenther  <rguenther@suse.de>
 
        * trans-expr.c (fill_with_spaces): Use fold_build_pointer_plus.

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b8eb5552a40e554eff8ed2df8657713ef3c65678..e5394b876df3d9f719e903e172d9bf069ab68eef 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4154,6 +4154,73 @@ gfc_is_coindexed (gfc_expr *e)
 }
 
 
+/* Coarrays are variables with a corank but not being coindexed. However, also
+   the following is a coarray: A subobject of a coarray is a coarray if it does
+   not have any cosubscripts, vector subscripts, allocatable component
+   selection, or pointer component selection. (F2008, 2.4.7)  */
+
+bool
+gfc_is_coarray (gfc_expr *e)
+{
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  gfc_component *comp;
+  bool coindexed;
+  bool coarray;
+  int i;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  coindexed = false;
+  sym = e->symtree->n.sym;
+
+  if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+    coarray = CLASS_DATA (sym)->attr.codimension;
+  else
+    coarray = sym->attr.codimension;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    switch (ref->type)
+    {
+      case REF_COMPONENT:
+       comp = ref->u.c.component;
+        if (comp->attr.pointer || comp->attr.allocatable)
+         {
+           coindexed = false;
+           if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
+             coarray = CLASS_DATA (comp)->attr.codimension;
+           else
+             coarray = comp->attr.codimension;
+         }
+        break;
+
+     case REF_ARRAY:
+       if (!coarray)
+         break;
+
+       if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
+         {
+           coindexed = true;
+           break;
+         }
+
+       for (i = 0; i < ref->u.ar.dimen; i++)
+         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+           {
+             coarray = false;
+             break;
+           }
+       break;
+
+     case REF_SUBSTRING:
+       break;
+    }
+
+  return coarray && !coindexed;
+}
+
+
 int
 gfc_get_corank (gfc_expr *e)
 {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index eb01b0e3d470decc5a65cdd6978ecf7e05ccf0a1..acb54004e9d8159992d360839fd6b98e7ff6fadd 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2735,6 +2735,7 @@ bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
 bool gfc_ref_this_image (gfc_ref *ref);
 bool gfc_is_coindexed (gfc_expr *);
+bool gfc_is_coarray (gfc_expr *);
 int gfc_get_corank (gfc_expr *);
 bool gfc_has_ultimate_allocatable (gfc_expr *);
 bool gfc_has_ultimate_pointer (gfc_expr *);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dcf6c4e9bd15f66b77505917554262ecd1a9b596..482a75e6fe0f106bf248676423a4345c8adf1102 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1557,47 +1557,26 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
        }
     }
 
-  if (formal->attr.codimension)
+  if (formal->attr.codimension && !gfc_is_coarray (actual))
     {
-      gfc_ref *last = NULL;
-
-      if (actual->expr_type != EXPR_VARIABLE
-         || !gfc_expr_attr (actual).codimension)
-       {
-         if (where)
-           gfc_error ("Actual argument to '%s' at %L must be a coarray",
+      if (where)
+       gfc_error ("Actual argument to '%s' at %L must be a coarray",
                       formal->name, &actual->where);
-         return 0;
-       }
+      return 0;
+    }
 
-      if (gfc_is_coindexed (actual))
-       {
-         if (where)
-           gfc_error ("Actual argument to '%s' at %L must be a coarray "
-                      "and not coindexed", formal->name, &actual->where);
-         return 0;
-       }
+  if (formal->attr.codimension && formal->attr.allocatable)
+    {
+      gfc_ref *last = NULL;
 
       for (ref = actual->ref; ref; ref = ref->next)
-       {
-         if (ref->type == REF_ARRAY && ref->u.ar.as->corank
-             && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
-           {
-             if (where)
-               gfc_error ("Actual argument to '%s' at %L must be a coarray "
-                          "and thus shall not have an array designator",
-                          formal->name, &ref->u.ar.where);
-             return 0;
-           }
-         if (ref->type == REF_COMPONENT)
-           last = ref;
-       }
+       if (ref->type == REF_COMPONENT)
+         last = ref;
 
       /* F2008, 12.5.2.6.  */
-      if (formal->attr.allocatable &&
-         ((last && last->u.c.component->as->corank != formal->as->corank)
-          || (!last
-              && actual->symtree->n.sym->as->corank != formal->as->corank)))
+      if ((last && last->u.c.component->as->corank != formal->as->corank)
+         || (!last
+             && actual->symtree->n.sym->as->corank != formal->as->corank))
        {
          if (where)
            gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
@@ -1606,7 +1585,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                        : actual->symtree->n.sym->as->corank);
          return 0;
        }
+    }
 
+  if (formal->attr.codimension)
+    {
       /* F2008, 12.5.2.8.  */
       if (formal->attr.dimension
          && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
@@ -1633,7 +1615,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                       formal->name, &actual->where);
          return 0;
        }
-      }
+    }
 
   /* F2008, C1239/C1240.  */
   if (actual->expr_type == EXPR_VARIABLE

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4e77decb5b443da3b6ea3f99e9b6d69499570c5b..1216d41ff435089e65f8c3939fc80263c81d9630 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-07-19  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray_args_1.f90: New.
+       * gfortran.dg/coarray_args_2.f90: New.
+
 2011-07-19  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/49708

diff --git a/gcc/testsuite/gfortran.dg/coarray_args_1.f90 b/gcc/testsuite/gfortran.dg/coarray_args_1.f90
new file mode 100644 (file)
index 0000000..0a3cada
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_args_1.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Argument checking
+!
+  implicit none
+  type t
+    integer :: i
+    integer,allocatable :: j
+  end type t
+
+  type(t), save :: x[*]
+
+  call sub1(x%i)
+  call sub1(x[1]%i) ! { dg-error "must be a coarray" }
+contains
+  subroutine sub1(y)
+    integer :: y[*]
+  end subroutine sub1
+end

diff --git a/gcc/testsuite/gfortran.dg/coarray_args_2.f90 b/gcc/testsuite/gfortran.dg/coarray_args_2.f90
new file mode 100644 (file)
index 0000000..66a5a92
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_args_2.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Check argument passing.
+! Taken from Reinhold Bader's fortran_tests.
+! 
+
+module mod_rank_mismatch_02
+  implicit none
+  integer, parameter :: ndim = 2
+contains
+  subroutine subr(n,w)
+    integer :: n
+    real :: w(n,*)[*] 
+
+    integer :: k, x
+
+    if (this_image() == 0) then
+       x = 1.0
+       do k = 1, num_images() 
+           if (abs(w(2,1)[k] - x) > 1.0e-5) then
+              write(*, *) 'FAIL'
+              error stop
+           end if
+           x = x + 1.0
+       end do
+    end if
+
+  end subroutine
+end module
+
+program rank_mismatch_02
+  use mod_rank_mismatch_02
+  implicit none
+  real :: a(ndim,2)[*]
+
+  a = 0.0
+  a(2,2) = 1.0 * this_image() 
+
+  sync all
+
+  call subr(ndim, a(1:1,2)) ! OK
+  call subr(ndim, a(1,2)) ! { dg-error "must be simply contiguous" }
+                          ! See also F08/0048 and PR 45859 about the validity
+  if (this_image() == 1) then
+     write(*, *) 'OK'
+  end if
+end program
+
+! { dg-final { cleanup-modules "mod_rank_mismatch_02" } }