re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2010-04-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * decl.c (variable_decl, match_attr_spec): Fix setting the array
        spec.
        * array.c (match_subscript,gfc_match_array_ref): Add coarray
        * support.
        * data.c (gfc_assign_data_value): Ditto.
        * expr.c (gfc_check_pointer_assign): Add check for coarray
        * constraint.
        (gfc_traverse_expr): Traverse also through codimension expressions.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): New functions.
        * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for
        * coarrays.
        (gfc_array_ref): Add codimen.
        (gfc_array_ref): Add in_allocate.
        (gfc_is_coindexed, gfc_has_ultimate_allocatable,
        gfc_has_ultimate_pointer): Add prototypes.
        * interface.c (compare_parameter, compare_actual_formal,
        check_intents): Add coarray constraints.
        * match.c (gfc_match_iterator): Add coarray constraint.
        * match.h (gfc_match_array_ref): Update interface.
        * primary.c (gfc_match_varspec): Handle codimensions.
        * resolve.c (coarray_alloc, inquiry_argument): New static
        * variables.
        (check_class_members): Return gfc_try instead for error recovery.
        (resolve_typebound_function,resolve_typebound_subroutine,
        check_members): Handle return value of check_class_members.
        (resolve_structure_cons, resolve_actual_arglist, resolve_function,
        check_dimension, compare_spec_to_ref, resolve_array_ref,
        resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
        resolve_allocate_expr, resolve_ordinary_assign): Add coarray
        support.
        * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
        Skip over coarray refs.
        (gfc_array_allocate) Add support for references containing coindexes.
        * trans-expr.c (gfc_add_interface_mapping): Copy coarray
        * attribute.
        (gfc_map_intrinsic_function): Ignore codimensions.

2010-04-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_7.f90: New test.
        * gfortran.dg/coarray_8.f90: New test.

From-SVN: r158149

gcc/fortran/ChangeLog

+2010-04-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* decl.c (variable_decl, match_attr_spec): Fix setting the array
+	spec.
+	* array.c (match_subscript,gfc_match_array_ref): Add coarray support.
+	* data.c (gfc_assign_data_value): Ditto.
+	* expr.c (gfc_check_pointer_assign): Add check for coarray constraint.
+	(gfc_traverse_expr): Traverse also through codimension expressions.
+	(gfc_is_coindexed, gfc_has_ultimate_allocatable,
+	gfc_has_ultimate_pointer): New functions.
+	* gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays.
+	(gfc_array_ref): Add codimen.
+	(gfc_array_ref): Add in_allocate.
+	(gfc_is_coindexed, gfc_has_ultimate_allocatable,
+	gfc_has_ultimate_pointer): Add prototypes.
+	* interface.c (compare_parameter, compare_actual_formal,
+	check_intents): Add coarray constraints.
+	* match.c (gfc_match_iterator): Add coarray constraint.
+	* match.h (gfc_match_array_ref): Update interface.
+	* primary.c (gfc_match_varspec): Handle codimensions.
+	* resolve.c (coarray_alloc, inquiry_argument): New static variables.
+	(check_class_members): Return gfc_try instead for error recovery.
+	(resolve_typebound_function,resolve_typebound_subroutine,
+	check_members): Handle return value of check_class_members.
+	(resolve_structure_cons, resolve_actual_arglist, resolve_function,
+	check_dimension, compare_spec_to_ref, resolve_array_ref,
+	resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
+	resolve_allocate_expr, resolve_ordinary_assign): Add coarray
+	support.
+	* trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
+	Skip over coarray refs.
+	(gfc_array_allocate) Add support for references containing coindexes.
+	* trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute.
+	(gfc_map_intrinsic_function): Ignore codimensions.
+
 2010-04-08  Bud Davis  <bdavis9659@sbcglobal.net>
 
 	PR fortran/28039

gcc/fortran/array.c

@@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src)
    expression.  */
 
 static match
-match_subscript (gfc_array_ref *ar, int init)
+match_subscript (gfc_array_ref *ar, int init, bool match_star)
 {
   match m;
+  bool star = false;
   int i;
 
-  i = ar->dimen;
+  i = ar->dimen + ar->codimen;
 
   ar->c_where[i] = gfc_current_locus;
   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
@@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init)
     goto end_element;
 
   /* Get start element.  */
-  if (init)
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+
+  if (!star && init)
     m = gfc_match_init_expr (&ar->start[i]);
-  else
+  else if (!star)
     m = gfc_match_expr (&ar->start[i]);
 
   if (m == MATCH_NO)
@@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init)
     return MATCH_ERROR;
 
   if (gfc_match_char (':') == MATCH_NO)
-    return MATCH_YES;
+    goto matched;
+
+  if (star)
+    {
+      gfc_error ("Unexpected '*' in coarray subscript at %C");
+      return MATCH_ERROR;
+    }
 
   /* Get an optional end element.  Because we've seen the colon, we
      definitely have a range along this dimension.  */
 end_element:
   ar->dimen_type[i] = DIMEN_RANGE;
 
-  if (init)
+  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+    star = true;
+  else if (init)
     m = gfc_match_init_expr (&ar->end[i]);
   else
     m = gfc_match_expr (&ar->end[i]);
@@ -110,6 +122,12 @@ end_element:
   /* See if we have an optional stride.  */
   if (gfc_match_char (':') == MATCH_YES)
     {
+      if (star)
+	{
+	  gfc_error ("Strides not allowed in coarray subscript at %C");
+	  return MATCH_ERROR;
+	}
+
       m = init ? gfc_match_init_expr (&ar->stride[i])
 	       : gfc_match_expr (&ar->stride[i]);
 
@@ -119,6 +137,10 @@ end_element:
 	return MATCH_ERROR;
     }
 
+matched:
+  if (star)
+    ar->dimen_type[i] = DIMEN_STAR;
+
   return MATCH_YES;
 }
 
@@ -128,14 +150,23 @@ end_element:
    to consist of init expressions.  */
 
 match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
+		     int corank)
 {
   match m;
+  bool matched_bracket = false;
 
   memset (ar, '\0', sizeof (ar));
 
   ar->where = gfc_current_locus;
   ar->as = as;
+  ar->type = AR_UNKNOWN;
+
+  if (gfc_match_char ('[') == MATCH_YES)
+    {
+       matched_bracket = true;
+       goto coarray;
+    }
 
   if (gfc_match_char ('(') != MATCH_YES)
     {
@@ -144,34 +175,73 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
       return MATCH_YES;
     }
 
-  ar->type = AR_UNKNOWN;
-
   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
     {
-      m = match_subscript (ar, init);
+      m = match_subscript (ar, init, false);
       if (m == MATCH_ERROR)
-	goto error;
+	return MATCH_ERROR;
 
       if (gfc_match_char (')') == MATCH_YES)
-	goto matched;
+	{
+	  ar->dimen++;
+	  goto coarray;
+	}
 
       if (gfc_match_char (',') != MATCH_YES)
 	{
 	  gfc_error ("Invalid form of array reference at %C");
-	  goto error;
+	  return MATCH_ERROR;
 	}
     }
 
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
 	     GFC_MAX_DIMENSIONS);
-
-error:
   return MATCH_ERROR;
 
-matched:
-  ar->dimen++;
+coarray:
+  if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+    {
+      if (ar->dimen > 0)
+	return MATCH_YES;
+      else
+	return MATCH_ERROR;
+    }
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return MATCH_ERROR;
+    }
+
+  if (corank == 0)
+    {
+	gfc_error ("Unexpected coarray designator at %C");
+	return MATCH_ERROR;
+    }
+
+  for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+    {
+      m = match_subscript (ar, init, ar->codimen == (corank - 1));
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+
+      if (gfc_match_char (']') == MATCH_YES)
+	{
+	  ar->codimen++;
+	  return MATCH_YES;
+	}
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Invalid form of coarray reference at %C");
+	  return MATCH_ERROR;
+	}
+    }
+
+  gfc_error ("Array reference at %C cannot have more than %d dimensions",
+	     GFC_MAX_DIMENSIONS);
+  return MATCH_ERROR;
 
-  return MATCH_YES;
 }
 
 
@@ -460,8 +530,8 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-       goto cleanup;
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      goto cleanup;
     }
 
   for (;;)

gcc/fortran/data.c

@@ -289,6 +289,14 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
       switch (ref->type)
 	{
 	case REF_ARRAY:
+	  if (ref->u.ar.as->rank == 0)
+	    {
+	      gcc_assert (ref->u.ar.as->corank > 0);
+	      if (init == NULL)
+		gfc_free (expr);
+	      continue;
+	    }
+
 	  if (init && expr->expr_type != EXPR_ARRAY)
 	    {
 	      gfc_error ("'%s' at %L already is initialized at %L",

gcc/fortran/decl.c

@@ -570,6 +570,62 @@ cleanup:
 
 /************************ Declaration statements *********************/
 
+
+/* Auxilliary function to merge DIMENSION and CODIMENSION array specs.  */
+
+static void
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+  int i;
+
+  if (to->rank == 0 && from->rank > 0)
+    {
+      to->rank = from->rank;
+      to->type = from->type;
+      to->cray_pointee = from->cray_pointee;
+      to->cp_was_assumed = from->cp_was_assumed;
+
+      for (i = 0; i < to->corank; i++)
+	{
+	  to->lower[from->rank + i] = to->lower[i];
+	  to->upper[from->rank + i] = to->upper[i];
+	}
+      for (i = 0; i < from->rank; i++)
+	{
+	  if (copy)
+	    {
+	      to->lower[i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[i] = gfc_copy_expr (from->upper[i]);
+	    }
+	  else
+	    {
+	      to->lower[i] = from->lower[i];
+	      to->upper[i] = from->upper[i];
+	    }
+	}
+    }
+  else if (to->corank == 0 && from->corank > 0)
+    {
+      to->corank = from->corank;
+      to->cotype = from->cotype;
+
+      for (i = 0; i < from->corank; i++)
+	{
+	  if (copy)
+	    {
+	      to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+	    }
+	  else
+	    {
+	      to->lower[to->rank + i] = from->lower[i];
+	      to->upper[to->rank + i] = from->upper[i];
+	    }
+	}
+    }
+}
+
+
 /* Match an intent specification.  Since this can only happen after an
    INTENT word, a legal intent-spec must follow.  */
 
@@ -1603,6 +1659,8 @@ variable_decl (int elem)
 
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
+  else if (current_as)
+    merge_array_spec (current_as, as, true);
 
   char_len = NULL;
   cl = NULL;
@@ -3050,27 +3108,27 @@ match_attr_spec (void)
       seen[d]++;
       seen_at[d] = gfc_current_locus;
 
-      if (d == DECL_DIMENSION)
+      if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
 	{
-	  m = gfc_match_array_spec (&current_as, true, false);
+	  gfc_array_spec *as = NULL;
 
-	  if (m == MATCH_NO)
+	  m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+				    d == DECL_CODIMENSION);
+
+	  if (current_as == NULL)
+	    current_as = as;
+	  else if (m == MATCH_YES)
 	    {
-	      gfc_error ("Missing dimension specification at %C");
-	      m = MATCH_ERROR;
+	      merge_array_spec (as, current_as, false);
+	      gfc_free (as);
 	    }
 
-	  if (m == MATCH_ERROR)
-	    goto cleanup;
-	}
-
-      if (d == DECL_CODIMENSION)
-	{
-	  m = gfc_match_array_spec (&current_as, false, true);
-
 	  if (m == MATCH_NO)
 	    {
-	      gfc_error ("Missing codimension specification at %C");
+	      if (d == DECL_CODIMENSION)
+		gfc_error ("Missing codimension specification at %C");
+	      else
+		gfc_error ("Missing dimension specification at %C");
 	      m = MATCH_ERROR;
 	    }
 

gcc/fortran/expr.c

@@ -3205,6 +3205,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
+  /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283.  */
+  if (lvalue->expr_type == EXPR_VARIABLE
+      && gfc_is_coindexed (lvalue))
+    {
+      gfc_ref *ref;
+      for (ref = lvalue->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+	  {
+	    gfc_error ("Pointer object at %L shall not have a coindex",
+		       &lvalue->where);
+	    return FAILURE;
+	  }
+    }
+
   /* Checks on rvalue for procedure pointer assignments.  */
   if (proc_pointer)
     {
@@ -3369,6 +3383,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
+  /* F2008, C725. For PURE also C1283.  */
+  if (rvalue->expr_type == EXPR_VARIABLE
+      && gfc_is_coindexed (rvalue))
+    {
+      gfc_ref *ref;
+      for (ref = rvalue->ref; ref; ref = ref->next)
+	if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+	  {
+	    gfc_error ("Data target at %L shall not have a coindex",
+		       &rvalue->where);
+	    return FAILURE;
+	  }
+    }
+
   return SUCCESS;
 }
 
@@ -3642,7 +3670,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 	    return true;
 
 	  if (ref->u.c.component->as)
-	    for (i = 0; i < ref->u.c.component->as->rank; i++)
+	    for (i = 0; i < ref->u.c.component->as->rank
+			    + ref->u.c.component->as->corank; i++)
 	      {
 		if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
 				       sym, func, f))
@@ -3836,3 +3865,75 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
   gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
 }
 
+
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+  gfc_ref *ref;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      return true;
+
+  return false;
+}
+
+
+/* Check whether the expression has an ultimate allocatable component.
+   Being itself allocatable does not count.  */
+bool
+gfc_has_ultimate_allocatable (gfc_expr *e)
+{
+  gfc_ref *ref, *last = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      last = ref;
+
+  if (last && last->u.c.component->ts.type == BT_CLASS)
+    return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
+  else if (last && last->u.c.component->ts.type == BT_DERIVED)
+    return last->u.c.component->ts.u.derived->attr.alloc_comp;
+  else if (last)
+    return false;
+
+  if (e->ts.type == BT_CLASS)
+    return e->ts.u.derived->components->attr.alloc_comp;
+  else if (e->ts.type == BT_DERIVED)
+    return e->ts.u.derived->attr.alloc_comp;
+  else
+    return false;
+}
+
+
+/* Check whether the expression has an pointer component.
+   Being itself a pointer does not count.  */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
+{
+  gfc_ref *ref, *last = NULL;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      last = ref;
+ 
+  if (last && last->u.c.component->ts.type == BT_CLASS)
+    return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
+  else if (last && last->u.c.component->ts.type == BT_DERIVED)
+    return last->u.c.component->ts.u.derived->attr.pointer_comp;
+  else if (last)
+    return false;
+
+  if (e->ts.type == BT_CLASS)
+    return e->ts.u.derived->components->attr.pointer_comp;
+  else if (e->ts.type == BT_DERIVED)
+    return e->ts.u.derived->attr.pointer_comp;
+  else
+    return false;
+}

gcc/fortran/gfortran.h

@@ -1444,13 +1444,15 @@ extern gfc_interface_info current_interface;
 
 enum gfc_array_ref_dimen_type
 {
-  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
 };
 
 typedef struct gfc_array_ref
 {
   ar_type type;
   int dimen;			/* # of components in the reference */
+  int codimen;
+  bool in_allocate;		/* For coarray checks. */
   locus where;
   gfc_array_spec *as;
 
@@ -2642,6 +2644,11 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
 
 bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
 
+bool gfc_is_coindexed (gfc_expr *);
+bool gfc_has_ultimate_allocatable (gfc_expr *);
+bool gfc_has_ultimate_pointer (gfc_expr *);
+
+
 /* st.c */
 extern gfc_code new_st;
 

gcc/fortran/interface.c

@@ -1445,6 +1445,65 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 0;
     }
 
+  if (formal->attr.codimension)
+    {
+      gfc_ref *last = NULL;
+
+      if (actual->expr_type != EXPR_VARIABLE
+	  || (actual->ref == NULL
+	      && !actual->symtree->n.sym->attr.codimension))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+
+      for (ref = actual->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+	    {
+	      if (where)
+		gfc_error ("Actual argument to '%s' at %L must be a coarray "
+			   "and not coindexed", formal->name, &ref->u.ar.where);
+	      return 0;
+	    }
+	  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 (last && !last->u.c.component->attr.codimension)
+      	{
+	  if (where)
+	    gfc_error ("Actual argument to '%s' at %L must be a coarray",
+		       formal->name, &actual->where);
+	  return 0;
+	}
+
+      /* 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 (where)
+	    gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+		   formal->name, &actual->where, formal->as->corank,
+		   last ? last->u.c.component->as->corank
+			: actual->symtree->n.sym->as->corank);
+	  return 0;
+	}
+    }
+
   if (symbol_rank (formal) == actual->rank)
     return 1;
 
@@ -1453,10 +1512,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		   || formal->as->type == AS_DEFERRED)
 	       && actual->expr_type != EXPR_NULL;
 
+  /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
   if (rank_check || ranks_must_agree
       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
-      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+      || (actual->rank == 0 && formal->attr.dimension
+	  && gfc_is_coindexed (actual)))
     {
       if (where)
 	gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
@@ -1474,7 +1536,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
      - (F2003) if the actual argument is of type character.  */
 
   for (ref = actual->ref; ref; ref = ref->next)
-    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+    if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+	&& ref->u.ar.dimen > 0)
       break;
 
   /* Not an array element.  */
@@ -1984,6 +2047,57 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
+      /* Fortran 2008, C1242.  */
+      if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to pointer "
+		       "dummy '%s'",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.5 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN
+	  && f->sym->attr.allocatable
+	  && gfc_is_coindexed (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L to allocatable "
+		       "dummy '%s' requires INTENT(IN)",
+		       &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, C1237.  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+	  && gfc_is_coindexed (a->expr)
+	  && (a->expr->symtree->n.sym->attr.volatile_
+	      || a->expr->symtree->n.sym->attr.asynchronous))
+	{
+	  if (where)
+	    gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+		       "at %L requires that dummy %s' has neither "
+		       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+		       f->sym->name);
+	  return 0;
+	}
+
+      /* Fortran 2008, 12.5.2.4 (no constraint).  */
+      if (a->expr->expr_type == EXPR_VARIABLE
+	  && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+	  && gfc_is_coindexed (a->expr)
+	  && gfc_has_ultimate_allocatable (a->expr))
+	{
+	  if (where)
+	    gfc_error ("Coindexed actual argument at %L with allocatable "
+		       "ultimate component to dummy '%s' requires either VALUE "
+		       "or INTENT(IN)", &a->expr->where, f->sym->name);
+	  return 0;
+	}
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_allocatable (f->sym, a->expr) == 0)
 	{
@@ -2367,6 +2481,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 	      return FAILURE;
 	    }
 	}
+
+       /* Fortran 2008, C1283.  */
+       if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+	{
+	  if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to an INTENT(%s) argument",
+			 &a->expr->where, gfc_intent_string (f_intent));
+	      return FAILURE;
+	    }
+
+	  if (f->sym->attr.pointer)
+	    {
+	      gfc_error ("Coindexed actual argument at %L in PURE procedure "
+			 "is passed to a POINTER dummy argument",
+			 &a->expr->where);
+	      return FAILURE;
+	    }
+	}
+
+       /* F2008, Section 12.5.2.4.  */
+       if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+	   && gfc_is_coindexed (a->expr))
+	 {
+	   gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+		      "polymorphic dummy argument '%s'",
+			 &a->expr->where, f->sym->name);
+	   return FAILURE;
+	 }
     }
 
   return SUCCESS;

gcc/fortran/match.c

@@ -949,6 +949,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
   locus start;
   match m;
 
+  e1 = e2 = e3 = NULL;
+
   /* Match the start of an iterator without affecting the symbol table.  */
 
   start = gfc_current_locus;
@@ -962,9 +964,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
   if (m != MATCH_YES)
     return MATCH_NO;
 
-  gfc_match_char ('=');
-
-  e1 = e2 = e3 = NULL;
+  /* F2008, C617 & C565.  */
+  if (var->symtree->n.sym->attr.codimension)
+    {
+      gfc_error ("Loop variable at %C cannot be a coarray");
+      goto cleanup;
+    }
 
   if (var->ref != NULL)
     {
@@ -979,6 +984,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
       goto cleanup;
     }
 
+  gfc_match_char ('=');
+
   var->symtree->n.sym->attr.implied_index = 1;
 
   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);

gcc/fortran/match.h

@@ -216,7 +216,7 @@ match gfc_match_init_expr (gfc_expr **);
 
 /* array.c.  */
 match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
 match gfc_match_array_constructor (gfc_expr **);
 
 /* interface.c.  */

gcc/fortran/primary.c

@@ -1746,7 +1746,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   tail = NULL;
 
   gfc_gobble_whitespace ();
+
+  if (gfc_peek_ascii_char () == '[')
+    {
+      if (sym->attr.dimension)
+	{
+	  gfc_error ("Array section designator, e.g. '(:)', is required "
+		     "besides the coarray designator '[...]' at %C");
+	  return MATCH_ERROR;
+	}
+      if (!sym->attr.codimension)
+	{
+	  gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+		     sym->name);
+	  return MATCH_ERROR;
+	}
+    }
+
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
+      || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && !sym->attr.proc_pointer
 	  && !gfc_is_proc_ptr_comp (primary, NULL)
 	  && !(gfc_matching_procptr_assignment
@@ -1761,7 +1779,7 @@ 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);
+			       equiv_flag, sym->as ? sym->as->corank : 0);
       if (m != MATCH_YES)
 	return m;
 
@@ -1771,7 +1789,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  tail = extend_ref (primary, tail);
 	  tail->type = REF_ARRAY;
 
-	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+	  m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
 	  if (m != MATCH_YES)
 	    return m;
 	}
@@ -1881,7 +1899,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  tail = extend_ref (primary, tail);
 	  tail->type = REF_ARRAY;
 
-	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+	  m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+			  component->as->corank);
 	  if (m != MATCH_YES)
 	    return m;
 	}
@@ -1894,7 +1913,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
 	  m = gfc_match_array_ref (&tail->u.ar,
 				   component->ts.u.derived->components->as,
-				   equiv_flag);
+				   equiv_flag,
+			   component->ts.u.derived->components->as->corank);
 	  if (m != MATCH_YES)
 	    return m;
 	}
@@ -1949,6 +1969,13 @@ check_substring:
 	}
     }
 
+  /* F2008, C727.  */
+  if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+    {
+      gfc_error ("Coindexed procedure-pointer component at %C");
+      return MATCH_ERROR;
+    }
+
   return MATCH_YES;
 }
 
@@ -2023,7 +2050,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	    break;
 
 	  case AR_ELEMENT:
-	    allocatable = pointer = 0;
+	    /* Handle coarrays.  */
+	    if (ref->u.ar.dimen > 0)
+	      allocatable = pointer = 0;
 	    break;
 
 	  case AR_UNKNOWN:
@@ -2349,6 +2378,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
 	  if (m == MATCH_ERROR)
 	    goto cleanup;
 
+	  /* F2008, R457/C725, for PURE C1283.  */
+          if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+	    {
+	      gfc_error ("Coindexed expression to pointer component '%s' in "
+			 "structure constructor at %C!", comp_tail->name);
+	      goto cleanup;
+ 	    }
+
+
 	  /* If not explicitly a parent constructor, gather up the components
 	     and build one.  */
 	  if (comp && comp == sym->components

gcc/fortran/trans-array.c

@@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
   gfc_se indexse;
   gfc_se tmpse;
 
+  if (ar->dimen == 0)
+    return;
+
   /* Handle scalarized references separately.  */
   if (ar->type != AR_ELEMENT)
     {
@@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   /* Find the last reference in the chain.  */
   while (ref && ref->next != NULL)
     {
-      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
       prev_ref = ref;
       ref = ref->next;
     }
@@ -3966,6 +3970,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   if (ref == NULL || ref->type != REF_ARRAY)
     return false;
 
+  /* Return if this is a scalar coarray.  */
+  if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+    {
+      gcc_assert (expr->symtree->n.sym->attr.codimension);
+      return false;
+    }
+  else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+    {
+      gcc_assert (prev_ref->u.c.component->attr.codimension);
+      return false;
+    }
+
   if (!prev_ref)
     allocatable_array = expr->symtree->n.sym->attr.allocatable;
   else
@@ -6361,6 +6377,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
 	continue;
 
       ar = &ref->u.ar;
+
+      if (ar->as->rank == 0)
+	{
+	  /* Scalar coarray.  */
+	  continue;
+	}
+
       switch (ar->type)
 	{
 	case AR_ELEMENT:

gcc/fortran/trans-expr.c

@@ -1848,6 +1848,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   new_sym->as = gfc_copy_array_spec (sym->as);
   new_sym->attr.referenced = 1;
   new_sym->attr.dimension = sym->attr.dimension;
+  new_sym->attr.codimension = sym->attr.codimension;
   new_sym->attr.pointer = sym->attr.pointer;
   new_sym->attr.allocatable = sym->attr.allocatable;
   new_sym->attr.flavor = sym->attr.flavor;
@@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
       break;
 
     case GFC_ISYM_SIZE:
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
 	return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)
@@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
 	/* TODO These implementations of lbound and ubound do not limit if
 	   the size < 0, according to F95's 13.14.53 and 13.14.113.  */
 
-      if (!sym->as)
+      if (!sym->as || sym->as->rank == 0)
 	return false;
 
       if (arg2 && arg2->expr_type == EXPR_CONSTANT)

gcc/testsuite/ChangeLog

+2010-04-09  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_7.f90: New test.
+	* gfortran.dg/coarray_8.f90: New test.
+
 2010-04-08  Bud Davis  <bdavis9659@sbcglobal.net>
 
 	PR fortran/28039

gcc/testsuite/gfortran.dg/coarray_7.f90

+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+program test
+  implicit none
+  type t3
+    integer, allocatable :: a
+  end type t3
+  type t4
+    type(t3) :: xt3
+  end type t4
+  type t
+    integer, pointer :: ptr
+    integer, allocatable :: alloc(:)
+  end type t
+  type(t), target :: i[*]
+  type(t), allocatable :: ca[:]
+  type(t4), target :: tt4[*]
+  type(t4), allocatable :: ca2[:]
+  integer, volatile :: volat[*]
+  integer, asynchronous :: async[*]
+  integer :: caf1[1,*], caf2[*]
+  allocate(i%ptr)
+  call foo(i%ptr)
+  call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" }
+  call bar(i%ptr)
+  call bar(i[1]%ptr) ! OK, value of ptr target 
+  call bar(i[1]%alloc(1)) ! OK
+  call typeDummy(i) ! OK
+  call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" }
+  call typeDummy2(ca) ! OK
+  call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" }
+  call typeDummy3(tt4%xt3) ! OK
+  call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." }
+  call typeDummy4(ca2) ! OK
+  call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." }
+! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in)
+! is not possible
+
+  call asyn(volat)
+  call asyn(async)
+  call asyn(volat[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+  call asyn(async[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+
+  call coarray(caf1) ! rank mismatch; OK, for non allocatable coarrays
+  call coarray(caf2)
+  call coarray(caf2[1]) ! { dg-error "must be a coarray" }
+  call ups(i)
+  call ups(i[1]) ! { dg-error "with ultimate pointer component" }
+  call ups(i%ptr)
+  call ups(i[1]%ptr) ! OK - passes target not pointer
+contains
+  subroutine asyn(a)
+    integer, intent(in), asynchronous :: a
+  end subroutine asyn
+  subroutine bar(a)
+    integer :: a
+  end subroutine bar
+  subroutine foo(a)
+    integer, pointer :: a
+  end subroutine foo
+  subroutine coarray(a)
+    integer :: a[*]
+  end subroutine coarray
+  subroutine typeDummy(a)
+    type(t) :: a
+  end subroutine typeDummy
+  subroutine typeDummy2(a)
+    type(t),allocatable :: a
+  end subroutine typeDummy2
+  subroutine typeDummy3(a)
+    type(t3) :: a
+  end subroutine typeDummy3
+  subroutine typeDummy4(a)
+    type(t4), allocatable :: a
+  end subroutine typeDummy4
+end program test
+
+
+subroutine alloc()
+type t
+  integer, allocatable :: a(:)
+end type t
+type(t), save :: a[*]
+type(t), allocatable :: b(:)[:], C[:]
+
+allocate(b(1)) ! { dg-error "Coarray specification" }
+allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" }
+allocate(c[*]) ! { dg-error "Sorry" }
+allocate(b(3)[5:*]) ! { dg-error "Sorry" }
+allocate(a%a(5)) ! OK
+end subroutine alloc
+
+
+subroutine dataPtr()
+  integer, save, target :: a[*]
+  data a/5/ ! OK
+  data a[1]/5/ ! { dg-error "cannot have a coindex" }
+  type t
+  integer, pointer :: p
+  end type t
+  type(t), save :: x[*]
+
+  type t2
+    integer :: a(1)
+  end type t2
+  type(t2) y
+  data y%a/4/
+
+
+   x[1]%p => a  ! { dg-error "shall not have a coindex" }
+   x%p => a[1]  ! { dg-error "shall not have a coindex" }
+end subroutine dataPtr
+
+
+subroutine test3()
+implicit none
+type t
+  integer :: a(1)
+end type t
+type(t), save :: x[*]
+data x%a/4/
+
+  integer, save :: y(1)[*] !(1)
+  call sub(x(1:1)[1]) ! { dg-error "Rank mismatch" }
+contains
+  subroutine sub(a) ! { dg-error "shall not have codimensions with deferred shape" }
+    integer :: a(:)[:]
+  end subroutine sub
+end subroutine test3
+
+
+subroutine test4()
+  integer, save :: i[*]
+  integer :: j
+  call foo(i)
+  call foo(j) ! { dg-error "must be a coarray" }
+contains
+  subroutine foo(a)
+    integer :: a[*]
+  end subroutine foo
+end subroutine test4
+
+
+subroutine allocateTest()
+  implicit none
+  real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c
+  integer :: n, q
+  n = 1
+  q = 1
+  allocate(a(n,n)[q,*]) ! { dg-error "Sorry" }
+  allocate(b(n,n)[q,*]) ! { dg-error "Sorry" }
+  allocate(c(n,n)[q,*]) ! { dg-error "Sorry" }
+end subroutine allocateTest
+
+
+subroutine testAlloc3
+implicit none
+integer, allocatable :: a(:,:,:)[:,:]
+integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
+
+allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(d(1,2)[3,*])   ! { dg-error "Sorry" }
+allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(f(1,2)[3,*]) ! { dg-error "Sorry" }
+end subroutine testAlloc3
+
+
+subroutine testAlloc4()
+  implicit none
+  type co_double_3
+    double precision, allocatable :: array(:)
+  end type co_double_3
+  type(co_double_3),save, codimension[*] :: work
+  allocate(work%array(1))
+  print *, size(work%array)
+end subroutine testAlloc4
+
+subroutine test5()
+  implicit none
+  integer, save :: i[*]
+  print *, i[*] ! { dg-error "Coindex of codimension 1 must be a scalar" }
+end subroutine test5
+

gcc/testsuite/gfortran.dg/coarray_8.f90

+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+module mod2
+  implicit none
+  type t
+    procedure(sub), pointer :: ppc
+  contains
+    procedure :: tbp => sub
+  end type t
+  type t2
+    class(t), allocatable :: poly
+  end type t2
+contains
+  subroutine sub(this)
+    class(t), intent(in) :: this
+  end subroutine sub
+end module mod2
+
+subroutine procTest(y,z)
+  use mod2
+  implicit none
+  type(t), save :: x[*]
+  type(t) :: y[*]
+  type(t2) :: z[*]
+
+  x%ppc => sub
+  call x%ppc() ! OK
+  call x%tbp() ! OK
+  call x[1]%tbp ! OK, not polymorphic
+  ! Invalid per C726
+  call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+  y%ppc => sub
+  call y%ppc() ! OK
+  call y%tbp() ! OK
+  call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj.
+  call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+  ! Invalid per C1229
+  z%poly%ppc => sub
+  call z%poly%ppc() ! OK
+  call z%poly%tbp() ! OK
+  call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" }
+  call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" }
+end subroutine procTest
+
+
+module m
+  type t1
+    integer, pointer :: p
+  end type t1
+  type t2
+    integer :: i
+  end type t2
+  type t
+    integer, allocatable :: a[:]
+    type(t1), allocatable :: b[:]
+    type(t2), allocatable :: c[:]
+  end type t
+contains
+  pure subroutine p2(x)
+   integer, intent(inout) :: x
+  end subroutine p2
+  pure subroutine p3(x)
+   integer, pointer :: x
+  end subroutine p3
+  pure subroutine p1(x)
+    type(t), intent(inout) :: x
+    integer, target :: tgt1
+    x%a = 5
+    x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" }
+    x%b%p => tgt1
+    x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+    x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" }
+    x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+    x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" }
+    call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" }
+    call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" }
+  end subroutine p1
+  subroutine nonPtr()
+    type(t1), save :: a[*]
+    type(t2), save :: b[*]
+    integer, target :: tgt1
+    a%p => tgt1
+    a[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+    a%p => a[2]%p ! { dg-error "shall not have a coindex" }
+    a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+    call p2 (b[1]%i) ! OK
+    call p2 (a[1]%p) ! OK - pointer target and not pointer
+  end subroutine nonPtr
+end module m
+
+
+module mmm3
+ type t
+   integer, allocatable :: a(:)
+ end type t
+contains
+  subroutine assign(x)
+    type(t) :: x[*]
+    allocate(x%a(3))
+    x%a = [ 1, 2, 3]
+    x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong
+                        ! (no reallocate on assignment)
+  end subroutine assign
+  subroutine assign2(x,y)
+    type(t),allocatable :: x[:]
+    type(t) :: y
+    x = y
+    x[1] = y ! { dg-error "must not be have an allocatable ultimate component" }
+  end subroutine assign2
+end module mmm3
+
+
+module mmm4
+  implicit none
+contains
+  subroutine t1(x)
+    integer :: x(1)
+  end subroutine t1
+  subroutine t3(x)
+    character :: x(*)
+  end subroutine t3
+  subroutine t2()
+    integer, save :: x[*]
+    integer, save :: y(1)[*]
+    character(len=20), save :: z[*]
+
+    call t1(x) ! { dg-error "Rank mismatch" }
+    call t1(x[1]) ! { dg-error "Rank mismatch" }
+
+    call t1(y(1)) ! OK
+    call t1(y(1)[1]) ! { dg-error "Rank mismatch" }
+
+    call t3(z) !  OK
+    call t3(z[1]) ! { dg-error "Rank mismatch" }
+  end subroutine t2
+end module mmm4
+
+
+subroutine tfgh()
+  integer :: i(2)
+  DATA i/(i, i=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+  do i = 1, 5 ! { dg-error "cannot be a sub-component" }
+  end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh
+
+subroutine tfgh2()
+  integer, save :: x[*]
+  integer :: i(2)
+  DATA i/(x, x=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+  do x = 1, 5 ! { dg-error "cannot be a coarray" }
+  end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh2
+
+
+subroutine f4f4()
+  type t
+    procedure(), pointer, nopass :: ppt => null()
+  end type t
+  external foo
+  type(t), save :: x[*]
+  x%ppt => foo
+  x[1]%ppt => foo ! { dg-error "shall not have a coindex" }
+end subroutine f4f4
+
+
+subroutine corank()
+  integer, allocatable :: a[:,:]
+  call one(a) ! OK
+  call two(a) !  { dg-error "Corank mismatch in argument" }
+contains
+  subroutine one(x)
+    integer :: x[*]
+  end subroutine one
+  subroutine two(x)
+    integer, allocatable :: x[:]
+  end subroutine two
+end subroutine corank
+
+subroutine assign42()
+  integer, allocatable :: z(:)[:]
+  z(:)[1] = z
+end subroutine assign42
+
+! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } }