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
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]);
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)
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)
{
/* 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++)
{
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)
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:
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;
}
*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]);
if (as1->rank != as2->rank)
return 0;
+ if (as1->corank != as2->corank)
+ return 0;
+
if (as1->rank == 0)
return 1;
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;
dimension attribute. */
attr = current_attr;
attr.dimension = 0;
+ attr.codimension = 0;
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
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
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)
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;
goto cleanup;
break;
+ case 'c':
+ if (match_string_p ("codimension"))
+ d = DECL_CODIMENSION;
+ break;
+
case 'd':
if (match_string_p ("dimension"))
d = DECL_DIMENSION;
if (d == DECL_DIMENSION)
{
- m = gfc_match_array_spec (¤t_as);
+ m = gfc_match_array_spec (¤t_as, true, false);
if (m == MATCH_NO)
{
if (m == MATCH_ERROR)
goto cleanup;
}
+
+ if (d == DECL_CODIMENSION)
+ {
+ m = gfc_match_array_spec (¤t_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
case DECL_ASYNCHRONOUS:
attr = "ASYNCHRONOUS";
break;
+ case DECL_CODIMENSION:
+ attr = "CODIMENSION";
+ break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
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)
{
t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
break;
+ case DECL_CODIMENSION:
+ t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
/* 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;
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))
{
}
else
{
- if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ if (current_attr.dimension == 0 && current_attr.codimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
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;
}
/* 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);
match
+gfc_match_codimension (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.codimension = 1;
+
+ return attr_decl ();
+}
+
+
+match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
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;
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)
{
}
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);
fputs (" ALLOCATABLE", dumpfile);
if (attr->asynchronous)
fputs (" ASYNCHRONOUS", dumpfile);
+ if (attr->codimension)
+ fputs (" CODIMENSION", dumpfile);
if (attr->dimension)
fputs (" DIMENSION", dumpfile);
if (attr->external)
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;
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;
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];
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 *);
/* 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;
/* 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);
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 **);
/* 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. */
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;
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),
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),
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)
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)
case AB_DIMENSION:
attr->dimension = 1;
break;
+ case AB_CODIMENSION:
+ attr->codimension = 1;
+ break;
case AB_EXTERNAL:
attr->external = 1;
break;
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;
}
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]);
break;
case 'c':
+ match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
break;
case 'd':
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':
&& 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
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 "
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;
/* 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)))
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;
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;
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)
}
}
+ 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:
*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;
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);
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);
/* 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);
conf (cray_pointer, entry);
conf (cray_pointee, allocatable);
+ conf (cray_pointer, codimension);
conf (cray_pointee, intent);
conf (cray_pointee, optional);
conf (cray_pointee, dummy);
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))
{
conf (procedure, allocatable)
conf (procedure, dimension)
+ conf (procedure, codimension)
conf (procedure, intrinsic)
conf (procedure, is_protected)
conf (procedure, target)
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
+ conf2 (codimension);
conf2 (dimension);
conf2 (dummy);
conf2 (volatile_);
conf2 (volatile_);
conf2 (asynchronous);
conf2 (in_namelist);
+ conf2 (codimension);
conf2 (dimension);
conf2 (function);
conf2 (threadprivate);
conf2 (threadprivate);
conf2 (value);
conf2 (is_bind_c);
+ conf2 (codimension);
conf2 (result);
break;
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)
{
{
/* 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,
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)
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 ();
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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
OSDN Git Service
