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

gcc/fortran/ChangeLog

+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.

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)
 {

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 *);

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/coarray_args_1.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_args_2.f90

+! { 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" } }