mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-11 01:30:55 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2010-04-06 20:16:13 +02:00 committed by Tobias Burnus
parent 385e814412
commit be59db2d47
15 changed files with 655 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/fortran/ChangeLog
View File

@ -1,3 +1,32 @@
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

235
gcc/fortran/array.c
View File

@ -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;

88
gcc/fortran/decl.c
View File

@ -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);
@ -6005,6 +6049,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)
{
@ -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;

8
gcc/fortran/dump-parse-tree.c
View File

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

6
gcc/fortran/gfortran.h
View File

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

2
gcc/fortran/match.c
View File

@ -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;

3
gcc/fortran/match.h
View File

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

20
gcc/fortran/module.c
View File

@ -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]);

6
gcc/fortran/parse.c
View File

@ -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

103
gcc/fortran/resolve.c
View File

@ -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:

45
gcc/fortran/symbol.c
View File

@ -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;
@ -865,6 +877,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 ();

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
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

86
gcc/testsuite/gfortran.dg/coarray_4.f90 Normal file
View File

@ -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

10
gcc/testsuite/gfortran.dg/coarray_5.f90 Normal file
View File

@ -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

58
gcc/testsuite/gfortran.dg/coarray_6.f90 Normal file
View File

@ -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" } }