aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorTobias Burnus <burnus@net-b.de>2010-04-06 20:16:13 +0200
committerTobias Burnus <burnus@gcc.gnu.org>2010-04-06 20:16:13 +0200
commitbe59db2d47d5de2c73132b9ea45bdfa7692a4bd8 (patch)
tree5e7fce8dfc8a026d1df286f7a6b7e2340402829b /gcc
parent385e8144121c9dfc0f8eb1a096db3e68183246bb (diff)
downloadgcc-be59db2d47d5de2c73132b9ea45bdfa7692a4bd8.zip
gcc-be59db2d47d5de2c73132b9ea45bdfa7692a4bd8.tar.gz
gcc-be59db2d47d5de2c73132b9ea45bdfa7692a4bd8.tar.bz2
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
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog29
-rw-r--r--gcc/fortran/array.c235
-rw-r--r--gcc/fortran/decl.c88
-rw-r--r--gcc/fortran/dump-parse-tree.c8
-rw-r--r--gcc/fortran/gfortran.h6
-rw-r--r--gcc/fortran/match.c2
-rw-r--r--gcc/fortran/match.h3
-rw-r--r--gcc/fortran/module.c20
-rw-r--r--gcc/fortran/parse.c6
-rw-r--r--gcc/fortran/resolve.c103
-rw-r--r--gcc/fortran/symbol.c45
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_4.f9086
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_5.f9010
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_6.f9058
15 files changed, 655 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 ();
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4053293..bcbc8d3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,6 +1,13 @@
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.
+
+2010-04-06 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
* gfortran.dg/iso_fortran_env_5.f90: New test.
* gfortran.dg/iso_fortran_env_6.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/coarray_4.f90 b/gcc/testsuite/gfortran.dg/coarray_4.f90
new file mode 100644
index 0000000..71fbf98
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_4.f90
@@ -0,0 +1,86 @@
+! { dg-do compile }
+!
+! Coarray support -- corank declarations
+! PR fortran/18918
+!
+
+subroutine valid(n, c, f)
+ implicit none
+ integer :: n
+ integer, save :: a[*], b(4)[-1:4,*]
+ real :: c(*)[1,0:3,3:*]
+ real :: f(n)[0:n,-100:*]
+ integer, allocatable :: d[:], e(:)[:,:]
+ integer, save, codimension[1,*] :: g, h(7), i(6)[*], j[*]
+ integer :: k
+ codimension :: k[*]
+ save :: k
+ integer :: ii = 7
+ block
+ integer, save :: kk[ii, *] ! { dg-error "cannot have the SAVE attribute" }
+ end block
+end subroutine valid
+
+subroutine valid2()
+ type t
+ integer, allocatable :: a[:]
+ end type t
+ type, extends(t) :: tt
+ integer, allocatable :: b[:]
+ end type tt
+ type(tt), save :: foo
+ type(tt) :: bar ! { dg-error "is a coarray or has a coarray component" }
+end subroutine valid2
+
+subroutine invalid(n)
+ implicit none
+ integer :: n
+ integer :: k[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" }
+ integer :: h(3)[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" }
+ integer, save :: a[*]
+ codimension :: a[1,*] ! { dg-error "Duplicate CODIMENSION attribute" }
+ complex, save :: hh(n)[*] ! { dg-error "cannot have the SAVE attribute" }
+ integer :: j = 6
+
+ integer, save :: hf1[j,*] ! { dg-error "cannot appear in the expression|cannot have the SAVE attribute" }
+ integer, save :: hf2[n,*] ! { dg-error "cannot have the SAVE attribute" }
+ integer, save :: hf3(4)[j,*] ! { dg-error "cannot appear in the expression|cannot have the SAVE attribute" }
+ integer, save :: hf4(5)[n,*] ! { dg-error "cannot have the SAVE attribute" }
+
+ integer, allocatable :: a2[*] ! { dg-error "must have deferred shape" }
+ integer, allocatable :: a3(:)[*] ! { dg-error "deferred shape and non-deferred coshape" }
+ integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" }
+end subroutine invalid
+
+subroutine invalid2
+ use iso_c_binding
+ implicit none
+ type t0
+ integer, allocatable :: a[:,:,:]
+ end type t0
+ type t
+ end type t
+ type, extends(t) :: tt ! { dg-error "has a coarray component, parent type" }
+ integer, allocatable :: a[:]
+ end type tt
+ type ttt
+ integer, pointer :: a[:] ! { dg-error "must be allocatable" }
+ end type ttt
+ type t4
+ integer, allocatable :: b[4,*] ! { dg-error "with deferred shape" }
+ end type t4
+ type t5
+ type(c_ptr), allocatable :: p[:] ! { dg-error "shall not be a coarray" }
+ end type t5
+ type(t0), save :: t0_1[*] ! { dg-error "shall be a nonpointer, nonallocatable scalar" }
+ type(t0), allocatable :: t0_2[:] ! { dg-error "shall be a nonpointer, nonallocatable scalar" }
+ type(c_ptr), save :: pp[*] ! { dg-error "shall not be a coarray" }
+end subroutine invalid2
+
+elemental subroutine elem(a) ! { dg-error "Coarray dummy argument" }
+ integer, intent(in) :: a[*]
+end subroutine
+
+function func() result(res)
+ integer :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" }
+end function func
diff --git a/gcc/testsuite/gfortran.dg/coarray_5.f90 b/gcc/testsuite/gfortran.dg/coarray_5.f90
new file mode 100644
index 0000000..46aa311
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_5.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! Coarray support -- corank declarations
+! PR fortran/18918
+!
+
+integer :: a, b[*] ! { dg-error "Fortran 2008: Coarray declaration" }
+codimension :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" }
+end
diff --git a/gcc/testsuite/gfortran.dg/coarray_6.f90 b/gcc/testsuite/gfortran.dg/coarray_6.f90
new file mode 100644
index 0000000..f122fd4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_6.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+!
+! Coarray support -- corank declarations
+! PR fortran/18918
+!
+module m2
+ use iso_c_binding
+ integer(c_int), bind(C) :: a[*] ! { dg-error "BIND.C. attribute conflicts with CODIMENSION" }
+
+ type, bind(C) :: t ! { dg-error "cannot have the ALLOCATABLE" }
+ integer(c_int), allocatable :: a[:] ! { dg-error "cannot have the ALLOCATABLE" }
+ integer(c_int) :: b[*] ! { dg-error "must be allocatable" }
+ end type t
+end module m2
+
+subroutine bind(a) bind(C) ! { dg-error "Coarray dummy variable" }
+ use iso_c_binding
+ integer(c_int) :: a[*]
+end subroutine bind
+
+subroutine allo(x) ! { dg-error "can thus not be an allocatable coarray" }
+ integer, allocatable, intent(out) :: x[:]
+end subroutine allo
+
+module m
+ integer :: modvar[*] ! OK, implicit save
+ type t
+ complex, allocatable :: b(:,:,:,:)[:,:,:]
+ end type t
+end module m
+
+subroutine bar()
+ integer, parameter :: a[*] = 4 ! { dg-error "PARAMETER attribute conflicts with CODIMENSION" }
+ integer, pointer :: b[:] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy" }
+end subroutine bar
+
+subroutine vol()
+ integer,save :: a[*]
+ block
+ volatile :: a ! { dg-error "Specifying VOLATILE for coarray" }
+ end block
+contains
+ subroutine int()
+ volatile :: a ! { dg-error "Specifying VOLATILE for coarray" }
+ end subroutine int
+end subroutine vol
+
+
+function func() result(func2) ! { dg-error "shall not be a coarray or have a coarray component" }
+ use m
+ type(t) :: func2
+end function func
+
+program main
+ integer :: A[*] ! Valid, implicit SAVE attribute
+end program main
+
+! { dg-final { cleanup-modules "m" } }