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

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

        PR fortran/18918
        * array.c (gfc_free_array_spec,gfc_resolve_array_spec,
        match_array_element_spec,gfc_copy_array_spec,
        gfc_compare_array_spec): Include corank.
        (match_array_element_spec,gfc_set_array_spec): Support codimension.
        * decl.c (build_sym,build_struct,variable_decl,
        match_attr_spec,attr_decl1,cray_pointer_decl,
        gfc_match_volatile): Add codimension.
        (gfc_match_codimension): New function.
        * dump-parse-tree.c (show_array_spec,show_attr): Support
        * codimension.
        * gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
        (gfc_add_codimension): New function prototype.
        * match.h (gfc_match_codimension): New function prototype.
        (gfc_match_array_spec): Update prototype
        * match.c (gfc_match_common): Update gfc_match_array_spec call.
        * module.c (MOD_VERSION): Bump.
        (mio_symbol_attribute): Support coarray attributes.
        (mio_array_spec): Add corank support.
        * parse.c (decode_specification_statement,decode_statement,
        parse_derived): Add coarray support.
        * resolve.c (resolve_formal_arglist, was_declared,
        is_non_constant_shape_array, resolve_fl_variable,
        resolve_fl_derived, resolve_symbol): Add coarray support.
        * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
        gfc_build_class_symbol): Add coarray support.
        (gfc_add_codimension): New function.

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

        PR fortran/18918
        * gfortran.dg/coarray_4.f90: New test.
        * gfortran.dg/coarray_5.f90: New test.
        * gfortran.dg/coarray_6.f90: New test.

From-SVN: r158012

11 files changed, 494 insertions, 51 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f68a6ca..f6cfcfd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,6 +1,35 @@
 2010-04-06  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/18918
+	* array.c (gfc_free_array_spec,gfc_resolve_array_spec,
+	match_array_element_spec,gfc_copy_array_spec,
+	gfc_compare_array_spec): Include corank.
+	(match_array_element_spec,gfc_set_array_spec): Support codimension.
+	* decl.c (build_sym,build_struct,variable_decl,
+	match_attr_spec,attr_decl1,cray_pointer_decl,
+	gfc_match_volatile): Add codimension.
+	(gfc_match_codimension): New function.
+	* dump-parse-tree.c (show_array_spec,show_attr): Support codimension.
+	* gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
+	(gfc_add_codimension): New function prototype.
+	* match.h (gfc_match_codimension): New function prototype.
+	(gfc_match_array_spec): Update prototype
+	* match.c (gfc_match_common): Update gfc_match_array_spec call.
+	* module.c (MOD_VERSION): Bump.
+	(mio_symbol_attribute): Support coarray attributes.
+	(mio_array_spec): Add corank support.
+	* parse.c (decode_specification_statement,decode_statement,
+	parse_derived): Add coarray support.
+	* resolve.c (resolve_formal_arglist, was_declared,
+	is_non_constant_shape_array, resolve_fl_variable,
+	resolve_fl_derived, resolve_symbol): Add coarray support.
+	* symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
+	gfc_build_class_symbol): Add coarray support.
+	(gfc_add_codimension): New function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
 	* iso-fortran-env.def: Add the integer parameters atomic_int_kind,
 	atomic_logical_kind, iostat_inquire_internal_unit, stat_locked,
 	stat_locked_other_image, stat_stopped_image and stat_unlocked of
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index e0714e3..4b2ccf6 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -188,7 +188,7 @@ gfc_free_array_spec (gfc_array_spec *as)
   if (as == NULL)
     return;
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       gfc_free_expr (as->lower[i]);
       gfc_free_expr (as->upper[i]);
@@ -234,7 +234,7 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
   if (as == NULL)
     return SUCCESS;
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       e = as->lower[i];
       if (resolve_array_bound (e, check_constant) == FAILURE)
@@ -290,8 +290,8 @@ match_array_element_spec (gfc_array_spec *as)
   gfc_expr **upper, **lower;
   match m;
 
-  lower = &as->lower[as->rank - 1];
-  upper = &as->upper[as->rank - 1];
+  lower = &as->lower[as->rank + as->corank - 1];
+  upper = &as->upper[as->rank + as->corank - 1];
 
   if (gfc_match_char ('*') == MATCH_YES)
     {
@@ -335,22 +335,20 @@ match_array_element_spec (gfc_array_spec *as)
 
 
 /* Matches an array specification, incidentally figuring out what sort
-   it is.  */
+   it is. Match either a normal array specification, or a coarray spec
+   or both. Optionally allow [:] for coarrays.  */
 
 match
-gfc_match_array_spec (gfc_array_spec **asp)
+gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
 {
   array_type current_type;
+  array_type coarray_type = AS_UNKNOWN;
   gfc_array_spec *as;
   int i;
-
-  if (gfc_match_char ('(') != MATCH_YES)
-    {
-      *asp = NULL;
-      return MATCH_NO;
-    }
-
+ 
   as = gfc_get_array_spec ();
+  as->corank = 0;
+  as->rank = 0;
 
   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
     {
@@ -358,10 +356,19 @@ gfc_match_array_spec (gfc_array_spec **asp)
       as->upper[i] = NULL;
     }
 
-  as->rank = 1;
+  if (!match_dim)
+    goto coarray;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
 
   for (;;)
     {
+      as->rank++;
       current_type = match_array_element_spec (as);
 
       if (as->rank == 1)
@@ -427,32 +434,150 @@ gfc_match_array_spec (gfc_array_spec **asp)
 	  goto cleanup;
 	}
 
-      if (as->rank >= GFC_MAX_DIMENSIONS)
+      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
 	{
 	  gfc_error ("Array specification at %C has more than %d dimensions",
 		     GFC_MAX_DIMENSIONS);
 	  goto cleanup;
 	}
 
-      if (as->rank >= 7
+      if (as->corank + as->rank >= 7
 	  && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
 			     "specification at %C with more than 7 dimensions")
 	     == FAILURE)
 	goto cleanup;
+    }
 
-      as->rank++;
+  if (!match_codim)
+    goto done;
+
+coarray:
+  if (gfc_match_char ('[')  != MATCH_YES)
+    goto done;
+
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
+      == FAILURE)
+    goto cleanup;
+
+  for (;;)
+    {
+      as->corank++;
+      current_type = match_array_element_spec (as);
+
+      if (current_type == AS_UNKNOWN)
+	goto cleanup;
+
+      if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED)
+	{
+	  gfc_error ("Array at %C has non-deferred shape and deferred "
+		     "coshape");
+          goto cleanup;
+	}
+      if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED)
+	{
+	  gfc_error ("Array at %C has deferred shape and non-deferred "
+		     "coshape");
+          goto cleanup;
+	}
+
+      if (as->corank == 1)
+	coarray_type = current_type;
+      else
+	switch (coarray_type)
+	  { /* See how current spec meshes with the existing.  */
+	    case AS_UNKNOWN:
+	      goto cleanup;
+
+	    case AS_EXPLICIT:
+	      if (current_type == AS_ASSUMED_SIZE)
+		{
+		  coarray_type = AS_ASSUMED_SIZE;
+		  break;
+		}
+
+	      if (current_type == AS_EXPLICIT)
+		break;
+
+	      gfc_error ("Bad array specification for an explicitly "
+			 "shaped array at %C");
+
+	      goto cleanup;
+
+	    case AS_ASSUMED_SHAPE:
+	      if ((current_type == AS_ASSUMED_SHAPE)
+		  || (current_type == AS_DEFERRED))
+		break;
+
+	      gfc_error ("Bad array specification for assumed shape "
+			 "array at %C");
+	      goto cleanup;
+
+	    case AS_DEFERRED:
+	      if (current_type == AS_DEFERRED)
+		break;
+
+	      if (current_type == AS_ASSUMED_SHAPE)
+		{
+		  as->type = AS_ASSUMED_SHAPE;
+		  break;
+		}
+
+	      gfc_error ("Bad specification for deferred shape array at %C");
+	      goto cleanup;
+
+	    case AS_ASSUMED_SIZE:
+	      gfc_error ("Bad specification for assumed size array at %C");
+	      goto cleanup;
+	  }
+
+      if (gfc_match_char (']') == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected another dimension in array declaration at %C");
+	  goto cleanup;
+	}
+
+      if (as->corank >= GFC_MAX_DIMENSIONS)
+	{
+	  gfc_error ("Array specification at %C has more than %d "
+		     "dimensions", GFC_MAX_DIMENSIONS);
+	  goto cleanup;
+	}
+    }
+
+  if (current_type == AS_EXPLICIT)
+    {
+      gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
+      goto cleanup;
+    }
+
+  if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
+    as->type = AS_EXPLICIT;
+  else if (as->rank == 0)
+    as->type = coarray_type;
+
+done:
+  if (as->rank == 0 && as->corank == 0)
+    {
+      *asp = NULL;
+      gfc_free_array_spec (as);
+      return MATCH_NO;
     }
 
   /* If a lower bounds of an assumed shape array is blank, put in one.  */
   if (as->type == AS_ASSUMED_SHAPE)
     {
-      for (i = 0; i < as->rank; i++)
+      for (i = 0; i < as->rank + as->corank; i++)
 	{
 	  if (as->lower[i] == NULL)
 	    as->lower[i] = gfc_int_expr (1);
 	}
     }
+
   *asp = as;
+
   return MATCH_YES;
 
 cleanup:
@@ -469,14 +594,77 @@ cleanup:
 gfc_try
 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
 {
+  int i;
+
   if (as == NULL)
     return SUCCESS;
 
-  if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
+  if (as->rank
+      && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
     return FAILURE;
 
-  sym->as = as;
+  if (as->corank
+      && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
+    return FAILURE;
+
+  if (sym->as == NULL)
+    {
+      sym->as = as;
+      return SUCCESS;
+    }
+
+  if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has deferred shape and non-deferred coshape",
+		 sym->name, error_loc);
+      return FAILURE;
+    }
+
+  if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has non-deferred shape and deferred coshape",
+		 sym->name, error_loc);
+      return FAILURE;
+    }
+
+  if (as->corank)
+    {
+      /* The "sym" has no corank (checked via gfc_add_codimension). Thus
+	 the codimension is simply added.  */
+      gcc_assert (as->rank == 0 && sym->as->corank == 0);
+
+      sym->as->corank = as->corank;
+      for (i = 0; i < as->corank; i++)
+	{
+	  sym->as->lower[sym->as->rank + i] = as->lower[i];
+	  sym->as->upper[sym->as->rank + i] = as->upper[i];
+	}
+    }
+  else
+    {
+      /* The "sym" has no rank (checked via gfc_add_dimension). Thus
+	 the dimension is added - but first the codimensions (if existing
+	 need to be shifted to make space for the dimension.  */
+      gcc_assert (as->corank == 0 && sym->as->rank == 0);
+
+      sym->as->rank = as->rank;
+      sym->as->type = as->type;
+      sym->as->cray_pointee = as->cray_pointee;
+      sym->as->cp_was_assumed = as->cp_was_assumed;
+
+      for (i = 0; i < sym->as->corank; i++)
+	{
+	  sym->as->lower[as->rank + i] = sym->as->lower[i];
+	  sym->as->upper[as->rank + i] = sym->as->upper[i];
+	}
+      for (i = 0; i < as->rank; i++)
+	{
+	  sym->as->lower[i] = as->lower[i];
+	  sym->as->upper[i] = as->upper[i];
+	}
+    }
 
+  gfc_free (as);
   return SUCCESS;
 }
 
@@ -496,7 +684,7 @@ gfc_copy_array_spec (gfc_array_spec *src)
 
   *dest = *src;
 
-  for (i = 0; i < dest->rank; i++)
+  for (i = 0; i < dest->rank + dest->corank; i++)
     {
       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
@@ -543,6 +731,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
   if (as1->rank != as2->rank)
     return 0;
 
+  if (as1->corank != as2->corank)
+    return 0;
+
   if (as1->rank == 0)
     return 1;
 
@@ -550,7 +741,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
     return 0;
 
   if (as1->type == AS_EXPLICIT)
-    for (i = 0; i < as1->rank; i++)
+    for (i = 0; i < as1->rank + as1->corank; i++)
       {
 	if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
 	  return 0;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 9237503..b376192 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1057,6 +1057,7 @@ build_sym (const char *name, gfc_charlen *cl,
      dimension attribute.  */
   attr = current_attr;
   attr.dimension = 0;
+  attr.codimension = 0;
 
   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
     return FAILURE;
@@ -1430,7 +1431,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 
   c->as = *as;
   if (c->as != NULL)
-    c->attr.dimension = 1;
+    {
+      if (c->as->corank)
+	c->attr.codimension = 1;
+      if (c->as->rank)
+	c->attr.dimension = 1;
+    }
   *as = NULL;
 
   /* Should this ever get more complicated, combine with similar section
@@ -1589,7 +1595,7 @@ variable_decl (int elem)
   var_locus = gfc_current_locus;
 
   /* Now we could see the optional array spec. or character length.  */
-  m = gfc_match_array_spec (&as);
+  m = gfc_match_array_spec (&as, true, true);
   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
     cp_as = gfc_copy_array_spec (as);
   else if (m == MATCH_ERROR)
@@ -2820,7 +2826,7 @@ match_attr_spec (void)
     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
-    DECL_IS_BIND_C, DECL_ASYNCHRONOUS, DECL_NONE,
+    DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE,
     GFC_DECL_END /* Sentinel */
   }
   decl_types;
@@ -2894,6 +2900,11 @@ match_attr_spec (void)
 		goto cleanup;
 	      break;
 
+	    case 'c':
+	      if (match_string_p ("codimension"))
+		d = DECL_CODIMENSION;
+	      break;
+
 	    case 'd':
 	      if (match_string_p ("dimension"))
 		d = DECL_DIMENSION;
@@ -3041,7 +3052,7 @@ match_attr_spec (void)
 
       if (d == DECL_DIMENSION)
 	{
-	  m = gfc_match_array_spec (&current_as);
+	  m = gfc_match_array_spec (&current_as, true, false);
 
 	  if (m == MATCH_NO)
 	    {
@@ -3052,6 +3063,20 @@ match_attr_spec (void)
 	  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");
+	      m = MATCH_ERROR;
+	    }
+
+	  if (m == MATCH_ERROR)
+	    goto cleanup;
+	}
     }
 
   /* Since we've seen a double colon, we have to be looking at an
@@ -3067,6 +3092,9 @@ match_attr_spec (void)
 	  case DECL_ASYNCHRONOUS:
 	    attr = "ASYNCHRONOUS";
 	    break;
+	  case DECL_CODIMENSION:
+	    attr = "CODIMENSION";
+	    break;
 	  case DECL_DIMENSION:
 	    attr = "DIMENSION";
 	    break;
@@ -3135,9 +3163,9 @@ match_attr_spec (void)
 	continue;
 
       if (gfc_current_state () == COMP_DERIVED
-	  && d != DECL_DIMENSION && d != DECL_POINTER
-	  && d != DECL_PRIVATE   && d != DECL_PUBLIC
-	  && d != DECL_NONE)
+	  && d != DECL_DIMENSION && d != DECL_CODIMENSION
+	  && d != DECL_POINTER   && d != DECL_PRIVATE
+	  && d != DECL_PUBLIC && d != DECL_NONE)
 	{
 	  if (d == DECL_ALLOCATABLE)
 	    {
@@ -3202,6 +3230,10 @@ match_attr_spec (void)
 	    t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
 	  break;
 
+	case DECL_CODIMENSION:
+	  t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
+	  break;
+
 	case DECL_DIMENSION:
 	  t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
 	  break;
@@ -5626,11 +5658,15 @@ attr_decl1 (void)
 
   /* Deal with possible array specification for certain attributes.  */
   if (current_attr.dimension
+      || current_attr.codimension
       || current_attr.allocatable
       || current_attr.pointer
       || current_attr.target)
     {
-      m = gfc_match_array_spec (&as);
+      m = gfc_match_array_spec (&as, !current_attr.codimension,
+				!current_attr.dimension
+				&& !current_attr.pointer
+				&& !current_attr.target);
       if (m == MATCH_ERROR)
 	goto cleanup;
 
@@ -5650,6 +5686,14 @@ attr_decl1 (void)
 	  goto cleanup;
 	}
 
+      if (current_attr.codimension && m == MATCH_NO)
+	{
+	  gfc_error ("Missing array specification at %L in CODIMENSION "
+		     "statement", &var_locus);
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+
       if ((current_attr.allocatable || current_attr.pointer)
 	  && (m == MATCH_YES) && (as->type != AS_DEFERRED))
 	{
@@ -5678,8 +5722,8 @@ attr_decl1 (void)
     }
   else
     {
-      if (current_attr.dimension == 0
-	    && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+      if (current_attr.dimension == 0 && current_attr.codimension == 0
+	  && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
 	{
 	  m = MATCH_ERROR;
 	  goto cleanup;
@@ -5777,7 +5821,7 @@ static match
 cray_pointer_decl (void)
 {
   match m;
-  gfc_array_spec *as;
+  gfc_array_spec *as = NULL;
   gfc_symbol *cptr; /* Pointer symbol.  */
   gfc_symbol *cpte; /* Pointee symbol.  */
   locus var_locus;
@@ -5846,7 +5890,7 @@ cray_pointer_decl (void)
 	}
 
       /* Check for an optional array spec.  */
-      m = gfc_match_array_spec (&as);
+      m = gfc_match_array_spec (&as, true, false);
       if (m == MATCH_ERROR)
 	{
 	  gfc_free_array_spec (as);
@@ -6006,6 +6050,16 @@ gfc_match_allocatable (void)
 
 
 match
+gfc_match_codimension (void)
+{
+  gfc_clear_attr (&current_attr);
+  current_attr.codimension = 1;
+
+  return attr_decl ();
+}
+
+
+match
 gfc_match_dimension (void)
 {
   gfc_clear_attr (&current_attr);
@@ -6493,11 +6547,19 @@ gfc_match_volatile (void)
   for(;;)
     {
       /* VOLATILE is special because it can be added to host-associated 
-	 symbols locally.  */
+	 symbols locally. Except for coarrays. */
       m = gfc_match_symbol (&sym, 1);
       switch (m)
 	{
 	case MATCH_YES:
+	  /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
+	     for variable in a BLOCK which is defined outside of the BLOCK.  */
+	  if (sym->ns != gfc_current_ns && sym->attr.codimension)
+	    {
+	      gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+			 "%C, which is use-/host-associated", sym->name);
+	      return MATCH_ERROR;
+	    }
 	  if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
 	      == FAILURE)
 	    return MATCH_ERROR;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 6c67e7d..e722ff0 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -141,9 +141,9 @@ show_array_spec (gfc_array_spec *as)
       return;
     }
 
-  fprintf (dumpfile, "(%d", as->rank);
+  fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
 
-  if (as->rank != 0)
+  if (as->rank + as->corank > 0)
     {
       switch (as->type)
       {
@@ -157,7 +157,7 @@ show_array_spec (gfc_array_spec *as)
       }
       fprintf (dumpfile, " %s ", c);
 
-      for (i = 0; i < as->rank; i++)
+      for (i = 0; i < as->rank + as->corank; i++)
 	{
 	  show_expr (as->lower[i]);
 	  fputc (' ', dumpfile);
@@ -591,6 +591,8 @@ show_attr (symbol_attribute *attr)
     fputs (" ALLOCATABLE", dumpfile);
   if (attr->asynchronous)
     fputs (" ASYNCHRONOUS", dumpfile);
+  if (attr->codimension)
+    fputs (" CODIMENSION", dumpfile);
   if (attr->dimension)
     fputs (" DIMENSION", dumpfile);
   if (attr->external)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1f98824..a2e385d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -651,7 +651,7 @@ extern const ext_attr_t ext_attr_list[];
 typedef struct
 {
   /* Variable attributes.  */
-  unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
+  unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
     implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1;
@@ -735,7 +735,7 @@ typedef struct
      possibly nested.  zero_comp is true if the derived type has no
      component at all.  */
   unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
-	   private_comp:1, zero_comp:1;
+	   private_comp:1, zero_comp:1, coarray_comp:1;
 
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
@@ -867,6 +867,7 @@ gfc_typespec;
 typedef struct
 {
   int rank;	/* A rank of zero means that a variable is a scalar.  */
+  int corank;
   array_type type;
   struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
 
@@ -2400,6 +2401,7 @@ void gfc_set_sym_referenced (gfc_symbol *);
 gfc_try gfc_add_attribute (symbol_attribute *, locus *);
 gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *);
 gfc_try gfc_add_allocatable (symbol_attribute *, locus *);
+gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *);
 gfc_try gfc_add_external (symbol_attribute *, locus *);
 gfc_try gfc_add_intrinsic (symbol_attribute *, locus *);
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 48bb733..e719628 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -3562,7 +3562,7 @@ gfc_match_common (void)
 
 	  /* Deal with an optional array specification after the
 	     symbol name.  */
-	  m = gfc_match_array_spec (&as);
+	  m = gfc_match_array_spec (&as, true, true);
 	  if (m == MATCH_ERROR)
 	    goto cleanup;
 
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index b03ee54..7a0f847 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -168,6 +168,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int);
 /* Matchers for attribute declarations.  */
 match gfc_match_allocatable (void);
 match gfc_match_asynchronous (void);
+match gfc_match_codimension (void);
 match gfc_match_dimension (void);
 match gfc_match_external (void);
 match gfc_match_gcc_attributes (void);
@@ -214,7 +215,7 @@ gfc_try gfc_reduce_init_expr (gfc_expr *expr);
 match gfc_match_init_expr (gfc_expr **);
 
 /* array.c.  */
-match gfc_match_array_spec (gfc_array_spec **);
+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_constructor (gfc_expr **);
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 666fd84..5c574bb 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -78,7 +78,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "4"
+#define MOD_VERSION "5"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1672,7 +1672,8 @@ typedef enum
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
-  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS
+  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
+  AB_COARRAY_COMP
 }
 ab_attribute;
 
@@ -1681,6 +1682,7 @@ static const mstring attr_bits[] =
     minit ("ALLOCATABLE", AB_ALLOCATABLE),
     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
     minit ("DIMENSION", AB_DIMENSION),
+    minit ("CODIMENSION", AB_CODIMENSION),
     minit ("EXTERNAL", AB_EXTERNAL),
     minit ("INTRINSIC", AB_INTRINSIC),
     minit ("OPTIONAL", AB_OPTIONAL),
@@ -1708,6 +1710,7 @@ static const mstring attr_bits[] =
     minit ("IS_ISO_C", AB_IS_ISO_C),
     minit ("VALUE", AB_VALUE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("COARRAY_COMP", AB_COARRAY_COMP),
     minit ("POINTER_COMP", AB_POINTER_COMP),
     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
     minit ("ZERO_COMP", AB_ZERO_COMP),
@@ -1798,6 +1801,8 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
       if (attr->dimension)
 	MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
+      if (attr->codimension)
+	MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
       if (attr->external)
 	MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
       if (attr->intrinsic)
@@ -1864,6 +1869,8 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
       if (attr->private_comp)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
+      if (attr->coarray_comp)
+	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
       if (attr->zero_comp)
 	MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
       if (attr->is_class)
@@ -1897,6 +1904,9 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_DIMENSION:
 	      attr->dimension = 1;
 	      break;
+	    case AB_CODIMENSION:
+	      attr->codimension = 1;
+	      break;
 	    case AB_EXTERNAL:
 	      attr->external = 1;
 	      break;
@@ -1984,6 +1994,9 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_ALLOC_COMP:
 	      attr->alloc_comp = 1;
 	      break;
+	    case AB_COARRAY_COMP:
+	      attr->coarray_comp = 1;
+	      break;
 	    case AB_POINTER_COMP:
 	      attr->pointer_comp = 1;
 	      break;
@@ -2131,9 +2144,10 @@ mio_array_spec (gfc_array_spec **asp)
     }
 
   mio_integer (&as->rank);
+  mio_integer (&as->corank);
   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       mio_expr (&as->lower[i]);
       mio_expr (&as->upper[i]);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7d935c3..b68afba 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -138,6 +138,7 @@ decode_specification_statement (void)
       break;
 
     case 'c':
+      match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
       break;
 
     case 'd':
@@ -349,6 +350,7 @@ decode_statement (void)
       match ("common", gfc_match_common, ST_COMMON);
       match ("contains", gfc_match_eos, ST_CONTAINS);
       match ("class", gfc_match_class_is, ST_CLASS_IS);
+      match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
       break;
 
     case 'd':
@@ -2112,6 +2114,10 @@ endType:
 	      && c->ts.u.derived->attr.proc_pointer_comp))
 	sym->attr.proc_pointer_comp = 1;
 
+      /* Looking for coarray components.  */
+      if (c->attr.codimension || c->attr.coarray_comp)
+	sym->attr.coarray_comp = 1;
+
       /* Look for private components.  */
       if (sym->component_access == ACCESS_PRIVATE
 	  || c->attr.access == ACCESS_PRIVATE
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8ef347d..55c0d12 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -258,6 +258,14 @@ resolve_formal_arglist (gfc_symbol *proc)
 
       if (gfc_elemental (proc))
 	{
+	  /* F2008, C1289.  */
+	  if (sym->attr.codimension)
+	    {
+	      gfc_error ("Coarray dummy argument '%s' at %L to elemental "
+			 "procedure", sym->name, &sym->declared_at);
+	      continue;
+	    }
+
 	  if (sym->as != NULL)
 	    {
 	      gfc_error ("Argument '%s' of elemental procedure at %L must "
@@ -955,7 +963,7 @@ was_declared (gfc_symbol *sym)
   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
       || a.optional || a.pointer || a.save || a.target || a.volatile_
       || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
-      || a.asynchronous)
+      || a.asynchronous || a.codimension)
     return 1;
 
   return 0;
@@ -8691,13 +8699,12 @@ is_non_constant_shape_array (gfc_symbol *sym)
       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
 	 has not been simplified; parameter array references.  Do the
 	 simplification now.  */
-      for (i = 0; i < sym->as->rank; i++)
+      for (i = 0; i < sym->as->rank + sym->as->corank; i++)
 	{
 	  e = sym->as->lower[i];
 	  if (e && (resolve_index_expr (e) == FAILURE
 		    || !gfc_is_constant_expr (e)))
 	    not_constant = true;
-
 	  e = sym->as->upper[i];
 	  if (e && (resolve_index_expr (e) == FAILURE
 		    || !gfc_is_constant_expr (e)))
@@ -9147,7 +9154,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
   if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
       || sym->attr.intrinsic || sym->attr.result)
     no_init_flag = 1;
-  else if (sym->attr.dimension && !sym->attr.pointer
+  else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer
 	   && is_non_constant_shape_array (sym))
     {
       no_init_flag = automatic_flag = 1;
@@ -10431,6 +10438,15 @@ resolve_fl_derived (gfc_symbol *sym)
 
   super_type = gfc_get_derived_super_type (sym);
 
+  /* F2008, C432. */
+  if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
+    {
+      gfc_error ("As extending type '%s' at %L has a coarray component, "
+		 "parent type '%s' shall also have one", sym->name,
+		 &sym->declared_at, super_type->name);
+      return FAILURE;
+    }
+
   /* Ensure the extended type gets resolved before we do.  */
   if (super_type && resolve_fl_derived (super_type) == FAILURE)
     return FAILURE;
@@ -10445,6 +10461,34 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      /* F2008, C442.  */
+      if (c->attr.codimension
+	  && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
+	{
+	  gfc_error ("Coarray component '%s' at %L must be allocatable with "
+		     "deferred shape", c->name, &c->loc);
+	  return FAILURE;
+	}
+
+      /* F2008, C443.  */
+      if (c->attr.codimension && c->ts.type == BT_DERIVED
+	  && c->ts.u.derived->ts.is_iso_c)
+	{
+	  gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+		     "shall not be a coarray", c->name, &c->loc);
+	  return FAILURE;
+	}
+
+      /* F2008, C444.  */
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+	  && (c->attr.codimension || c->attr.pointer || c->attr.dimension))
+	{
+	  gfc_error ("Component '%s' at %L with coarray component "
+		     "shall be a nonpointer, nonallocatable scalar",
+		     c->name, &c->loc);
+	  return FAILURE;
+	}
+
       if (c->attr.proc_pointer && c->ts.interface)
 	{
 	  if (c->ts.interface->attr.procedure)
@@ -11275,6 +11319,57 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->attr.codimension && sym->attr.allocatable
+      && sym->as->type != AS_DEFERRED)
+    gfc_error ("Allocatable coarray variable '%s' at %L must have "
+	       "deferred shape", sym->name, &sym->declared_at);
+
+  /* F2008, C526.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || sym->attr.codimension)
+      && sym->attr.result)
+    gfc_error ("Function result '%s' at %L shall not be a coarray or have "
+	       "a coarray component", sym->name, &sym->declared_at);
+
+  /* F2008, C524.  */
+  if (sym->attr.codimension && sym->ts.type == BT_DERIVED
+      && sym->ts.u.derived->ts.is_iso_c)
+    gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
+	       "shall not be a coarray", sym->name, &sym->declared_at);
+
+  /* F2008, C525.  */
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp
+      && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension
+	  || sym->attr.allocatable))
+    gfc_error ("Variable '%s' at %L with coarray component "
+	       "shall be a nonpointer, nonallocatable scalar",
+	       sym->name, &sym->declared_at);
+
+  /* F2008, C526.  The function-result case was handled above.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || sym->attr.codimension)
+      && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save
+	   || sym->ns->proc_name->attr.flavor == FL_MODULE
+	   || sym->ns->proc_name->attr.is_main_program
+	   || sym->attr.function || sym->attr.result || sym->attr.use_assoc))
+    gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
+	       "component and is not ALLOCATABLE, SAVE nor a "
+	       "dummy argument", sym->name, &sym->declared_at);
+
+  /* F2008, C541.  */
+  if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
+       || (sym->attr.codimension && sym->attr.allocatable))
+      && sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+    gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
+	       "allocatable coarray or have coarray components",
+	       sym->name, &sym->declared_at);
+
+  if (sym->attr.codimension && sym->attr.dummy
+      && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c)
+    gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
+	       "procedure '%s'", sym->name, &sym->declared_at,
+	       sym->ns->proc_name->name);
+
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 98af755..dbbc97c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -371,7 +371,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
-    *asynchronous = "ASYNCHRONOUS";
+    *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -477,11 +477,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 
   conf (in_common, dummy);
   conf (in_common, allocatable);
+  conf (in_common, codimension);
   conf (in_common, result);
 
   conf (dummy, result);
 
   conf (in_equivalence, use_assoc);
+  conf (in_equivalence, codimension);
   conf (in_equivalence, dummy);
   conf (in_equivalence, target);
   conf (in_equivalence, pointer);
@@ -503,6 +505,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 
   conf (is_bind_c, cray_pointer);
   conf (is_bind_c, cray_pointee);
+  conf (is_bind_c, codimension);
   conf (is_bind_c, allocatable);
   conf (is_bind_c, elemental);
 
@@ -513,6 +516,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   /* Cray pointer/pointee conflicts.  */
   conf (cray_pointer, cray_pointee);
   conf (cray_pointer, dimension);
+  conf (cray_pointer, codimension);
   conf (cray_pointer, pointer);
   conf (cray_pointer, target);
   conf (cray_pointer, allocatable);
@@ -524,6 +528,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (cray_pointer, entry);
 
   conf (cray_pointee, allocatable);
+  conf (cray_pointer, codimension);
   conf (cray_pointee, intent);
   conf (cray_pointee, optional);
   conf (cray_pointee, dummy);
@@ -547,8 +552,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (value, function)
   conf (value, volatile_)
   conf (value, dimension)
+  conf (value, codimension)
   conf (value, external)
 
+  conf (codimension, result)
+
   if (attr->value
       && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
     {
@@ -576,6 +584,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 
   conf (procedure, allocatable)
   conf (procedure, dimension)
+  conf (procedure, codimension)
   conf (procedure, intrinsic)
   conf (procedure, is_protected)
   conf (procedure, target)
@@ -601,6 +610,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
     case FL_BLOCK_DATA:
     case FL_MODULE:
     case FL_LABEL:
+      conf2 (codimension);
       conf2 (dimension);
       conf2 (dummy);
       conf2 (volatile_);
@@ -653,6 +663,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 	  conf2 (volatile_);
 	  conf2 (asynchronous);
 	  conf2 (in_namelist);
+	  conf2 (codimension);
 	  conf2 (dimension);
 	  conf2 (function);
 	  conf2 (threadprivate);
@@ -722,6 +733,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (threadprivate);
       conf2 (value);
       conf2 (is_bind_c);
+      conf2 (codimension);
       conf2 (result);
       break;
 
@@ -866,6 +878,32 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where)
 
 
 gfc_try
+gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
+{
+
+  if (check_used (attr, name, where))
+    return FAILURE;
+
+  if (attr->codimension)
+    {
+      duplicate_attr ("CODIMENSION", where);
+      return FAILURE;
+    }
+
+  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE)
+    {
+      gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
+		 "at %L", name, where);
+      return FAILURE;
+    }
+
+  attr->codimension = 1;
+  return check_conflict (attr, name, where);
+}
+
+
+gfc_try
 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
 {
 
@@ -1096,7 +1134,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
 {
   /* No check_used needed as 11.2.1 of the F2003 standard allows
      that the local identifier made accessible by a use statement can be
-     given a VOLATILE attribute.  */
+     given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
 
   if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
     if (gfc_notify_std (GFC_STD_LEGACY, 
@@ -1677,6 +1715,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
 
   if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
     goto fail;
   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
@@ -4713,6 +4753,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.pointer = attr->pointer || attr->dummy;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
+      c->attr.codimension = attr->codimension;
       c->attr.abstract = ts->u.derived->attr.abstract;
       c->as = (*as);
       c->initializer = gfc_get_expr ();