+2010-04-09 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * decl.c (variable_decl, match_attr_spec): Fix setting the array
+ spec.
+ * array.c (match_subscript,gfc_match_array_ref): Add coarray support.
+ * data.c (gfc_assign_data_value): Ditto.
+ * expr.c (gfc_check_pointer_assign): Add check for coarray constraint.
+ (gfc_traverse_expr): Traverse also through codimension expressions.
+ (gfc_is_coindexed, gfc_has_ultimate_allocatable,
+ gfc_has_ultimate_pointer): New functions.
+ * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays.
+ (gfc_array_ref): Add codimen.
+ (gfc_array_ref): Add in_allocate.
+ (gfc_is_coindexed, gfc_has_ultimate_allocatable,
+ gfc_has_ultimate_pointer): Add prototypes.
+ * interface.c (compare_parameter, compare_actual_formal,
+ check_intents): Add coarray constraints.
+ * match.c (gfc_match_iterator): Add coarray constraint.
+ * match.h (gfc_match_array_ref): Update interface.
+ * primary.c (gfc_match_varspec): Handle codimensions.
+ * resolve.c (coarray_alloc, inquiry_argument): New static variables.
+ (check_class_members): Return gfc_try instead for error recovery.
+ (resolve_typebound_function,resolve_typebound_subroutine,
+ check_members): Handle return value of check_class_members.
+ (resolve_structure_cons, resolve_actual_arglist, resolve_function,
+ check_dimension, compare_spec_to_ref, resolve_array_ref,
+ resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
+ resolve_allocate_expr, resolve_ordinary_assign): Add coarray
+ support.
+ * trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
+ Skip over coarray refs.
+ (gfc_array_allocate) Add support for references containing coindexes.
+ * trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute.
+ (gfc_map_intrinsic_function): Ignore codimensions.
+
2010-04-08 Bud Davis <bdavis9659@sbcglobal.net>
PR fortran/28039
expression. */
static match
-match_subscript (gfc_array_ref *ar, int init)
+match_subscript (gfc_array_ref *ar, int init, bool match_star)
{
match m;
+ bool star = false;
int i;
- i = ar->dimen;
+ i = ar->dimen + ar->codimen;
ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
goto end_element;
/* Get start element. */
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+
+ if (!star && init)
m = gfc_match_init_expr (&ar->start[i]);
- else
+ else if (!star)
m = gfc_match_expr (&ar->start[i]);
if (m == MATCH_NO)
return MATCH_ERROR;
if (gfc_match_char (':') == MATCH_NO)
- return MATCH_YES;
+ goto matched;
+
+ if (star)
+ {
+ gfc_error ("Unexpected '*' in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
/* Get an optional end element. Because we've seen the colon, we
definitely have a range along this dimension. */
end_element:
ar->dimen_type[i] = DIMEN_RANGE;
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+ else if (init)
m = gfc_match_init_expr (&ar->end[i]);
else
m = gfc_match_expr (&ar->end[i]);
/* See if we have an optional stride. */
if (gfc_match_char (':') == MATCH_YES)
{
+ if (star)
+ {
+ gfc_error ("Strides not allowed in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
+
m = init ? gfc_match_init_expr (&ar->stride[i])
: gfc_match_expr (&ar->stride[i]);
return MATCH_ERROR;
}
+matched:
+ if (star)
+ ar->dimen_type[i] = DIMEN_STAR;
+
return MATCH_YES;
}
to consist of init expressions. */
match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
+ int corank)
{
match m;
+ bool matched_bracket = false;
memset (ar, '\0', sizeof (ar));
ar->where = gfc_current_locus;
ar->as = as;
+ ar->type = AR_UNKNOWN;
+
+ if (gfc_match_char ('[') == MATCH_YES)
+ {
+ matched_bracket = true;
+ goto coarray;
+ }
if (gfc_match_char ('(') != MATCH_YES)
{
return MATCH_YES;
}
- ar->type = AR_UNKNOWN;
-
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
{
- m = match_subscript (ar, init);
+ m = match_subscript (ar, init, false);
if (m == MATCH_ERROR)
- goto error;
+ return MATCH_ERROR;
if (gfc_match_char (')') == MATCH_YES)
- goto matched;
+ {
+ ar->dimen++;
+ goto coarray;
+ }
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Invalid form of array reference at %C");
- goto error;
+ return MATCH_ERROR;
}
}
gfc_error ("Array reference at %C cannot have more than %d dimensions",
GFC_MAX_DIMENSIONS);
-
-error:
return MATCH_ERROR;
-matched:
- ar->dimen++;
+coarray:
+ if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+ {
+ if (ar->dimen > 0)
+ return MATCH_YES;
+ else
+ return MATCH_ERROR;
+ }
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
+ if (corank == 0)
+ {
+ gfc_error ("Unexpected coarray designator at %C");
+ return MATCH_ERROR;
+ }
+
+ for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+ {
+ m = match_subscript (ar, init, ar->codimen == (corank - 1));
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match_char (']') == MATCH_YES)
+ {
+ ar->codimen++;
+ return MATCH_YES;
+ }
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Invalid form of coarray reference at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
+ return MATCH_ERROR;
- return MATCH_YES;
}
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
{
- gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- goto cleanup;
+ gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ goto cleanup;
}
for (;;)
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.as->rank == 0)
+ {
+ gcc_assert (ref->u.ar.as->corank > 0);
+ if (init == NULL)
+ gfc_free (expr);
+ continue;
+ }
+
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("'%s' at %L already is initialized at %L",
/************************ Declaration statements *********************/
+
+/* Auxilliary function to merge DIMENSION and CODIMENSION array specs. */
+
+static void
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+ int i;
+
+ if (to->rank == 0 && from->rank > 0)
+ {
+ to->rank = from->rank;
+ to->type = from->type;
+ to->cray_pointee = from->cray_pointee;
+ to->cp_was_assumed = from->cp_was_assumed;
+
+ for (i = 0; i < to->corank; i++)
+ {
+ to->lower[from->rank + i] = to->lower[i];
+ to->upper[from->rank + i] = to->upper[i];
+ }
+ for (i = 0; i < from->rank; i++)
+ {
+ if (copy)
+ {
+ to->lower[i] = gfc_copy_expr (from->lower[i]);
+ to->upper[i] = gfc_copy_expr (from->upper[i]);
+ }
+ else
+ {
+ to->lower[i] = from->lower[i];
+ to->upper[i] = from->upper[i];
+ }
+ }
+ }
+ else if (to->corank == 0 && from->corank > 0)
+ {
+ to->corank = from->corank;
+ to->cotype = from->cotype;
+
+ for (i = 0; i < from->corank; i++)
+ {
+ if (copy)
+ {
+ to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
+ to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+ }
+ else
+ {
+ to->lower[to->rank + i] = from->lower[i];
+ to->upper[to->rank + i] = from->upper[i];
+ }
+ }
+ }
+}
+
+
/* Match an intent specification. Since this can only happen after an
INTENT word, a legal intent-spec must follow. */
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
+ else if (current_as)
+ merge_array_spec (current_as, as, true);
char_len = NULL;
cl = NULL;
seen[d]++;
seen_at[d] = gfc_current_locus;
- if (d == DECL_DIMENSION)
+ if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
{
- m = gfc_match_array_spec (¤t_as, true, false);
+ gfc_array_spec *as = NULL;
- if (m == MATCH_NO)
+ m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+ d == DECL_CODIMENSION);
+
+ if (current_as == NULL)
+ current_as = as;
+ else if (m == MATCH_YES)
{
- gfc_error ("Missing dimension specification at %C");
- m = MATCH_ERROR;
+ merge_array_spec (as, current_as, false);
+ gfc_free (as);
}
- if (m == MATCH_ERROR)
- goto cleanup;
- }
-
- if (d == DECL_CODIMENSION)
- {
- m = gfc_match_array_spec (¤t_as, false, true);
-
if (m == MATCH_NO)
{
- gfc_error ("Missing codimension specification at %C");
+ if (d == DECL_CODIMENSION)
+ gfc_error ("Missing codimension specification at %C");
+ else
+ gfc_error ("Missing dimension specification at %C");
m = MATCH_ERROR;
}
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
+ if (lvalue->expr_type == EXPR_VARIABLE
+ && gfc_is_coindexed (lvalue))
+ {
+ gfc_ref *ref;
+ for (ref = lvalue->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("Pointer object at %L shall not have a coindex",
+ &lvalue->where);
+ return FAILURE;
+ }
+ }
+
/* Checks on rvalue for procedure pointer assignments. */
if (proc_pointer)
{
return FAILURE;
}
+ /* F2008, C725. For PURE also C1283. */
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && gfc_is_coindexed (rvalue))
+ {
+ gfc_ref *ref;
+ for (ref = rvalue->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("Data target at %L shall not have a coindex",
+ &rvalue->where);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
return true;
if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
+ for (i = 0; i < ref->u.c.component->as->rank
+ + ref->u.c.component->as->corank; i++)
{
if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
sym, func, f))
gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
}
+
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return true;
+
+ return false;
+}
+
+
+/* Check whether the expression has an ultimate allocatable component.
+ Being itself allocatable does not count. */
+bool
+gfc_has_ultimate_allocatable (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.alloc_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.alloc_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.alloc_comp;
+ else
+ return false;
+}
+
+
+/* Check whether the expression has an pointer component.
+ Being itself a pointer does not count. */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.pointer_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.pointer_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.pointer_comp;
+ else
+ return false;
+}
enum gfc_array_ref_dimen_type
{
- DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN
+ DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
};
typedef struct gfc_array_ref
{
ar_type type;
int dimen; /* # of components in the reference */
+ int codimen;
+ bool in_allocate; /* For coarray checks. */
locus where;
gfc_array_spec *as;
bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
+bool gfc_is_coindexed (gfc_expr *);
+bool gfc_has_ultimate_allocatable (gfc_expr *);
+bool gfc_has_ultimate_pointer (gfc_expr *);
+
+
/* st.c */
extern gfc_code new_st;
return 0;
}
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
+
+ if (actual->expr_type != EXPR_VARIABLE
+ || (actual->ref == NULL
+ && !actual->symtree->n.sym->attr.codimension))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+ && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and thus shall not have an array designator",
+ formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+ }
+
+ if (last && !last->u.c.component->attr.codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
+ }
+
if (symbol_rank (formal) == actual->rank)
return 1;
|| formal->as->type == AS_DEFERRED)
&& actual->expr_type != EXPR_NULL;
+ /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
if (rank_check || ranks_must_agree
|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|| (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
- || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+ || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+ || (actual->rank == 0 && formal->attr.dimension
+ && gfc_is_coindexed (actual)))
{
if (where)
gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
- (F2003) if the actual argument is of type character. */
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0)
break;
/* Not an array element. */
return 0;
}
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.5 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN
+ && f->sym->attr.allocatable
+ && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to allocatable "
+ "dummy '%s' requires INTENT(IN)",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, C1237. */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+ && gfc_is_coindexed (a->expr)
+ && (a->expr->symtree->n.sym->attr.volatile_
+ || a->expr->symtree->n.sym->attr.asynchronous))
+ {
+ if (where)
+ gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+ "at %L requires that dummy %s' has neither "
+ "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+ f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.4 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+ && gfc_is_coindexed (a->expr)
+ && gfc_has_ultimate_allocatable (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L with allocatable "
+ "ultimate component to dummy '%s' requires either VALUE "
+ "or INTENT(IN)", &a->expr->where, f->sym->name);
+ return 0;
+ }
+
if (a->expr->expr_type != EXPR_NULL
&& compare_allocatable (f->sym, a->expr) == 0)
{
return FAILURE;
}
}
+
+ /* Fortran 2008, C1283. */
+ if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+ {
+ if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to an INTENT(%s) argument",
+ &a->expr->where, gfc_intent_string (f_intent));
+ return FAILURE;
+ }
+
+ if (f->sym->attr.pointer)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to a POINTER dummy argument",
+ &a->expr->where);
+ return FAILURE;
+ }
+ }
+
+ /* F2008, Section 12.5.2.4. */
+ if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+ && gfc_is_coindexed (a->expr))
+ {
+ gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+ "polymorphic dummy argument '%s'",
+ &a->expr->where, f->sym->name);
+ return FAILURE;
+ }
}
return SUCCESS;
locus start;
match m;
+ e1 = e2 = e3 = NULL;
+
/* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
if (m != MATCH_YES)
return MATCH_NO;
- gfc_match_char ('=');
-
- e1 = e2 = e3 = NULL;
+ /* F2008, C617 & C565. */
+ if (var->symtree->n.sym->attr.codimension)
+ {
+ gfc_error ("Loop variable at %C cannot be a coarray");
+ goto cleanup;
+ }
if (var->ref != NULL)
{
goto cleanup;
}
+ gfc_match_char ('=');
+
var->symtree->n.sym->attr.implied_index = 1;
m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
/* array.c. */
match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
match gfc_match_array_constructor (gfc_expr **);
/* interface.c. */
tail = NULL;
gfc_gobble_whitespace ();
+
+ if (gfc_peek_ascii_char () == '[')
+ {
+ if (sym->attr.dimension)
+ {
+ gfc_error ("Array section designator, e.g. '(:)', is required "
+ "besides the coarray designator '[...]' at %C");
+ return MATCH_ERROR;
+ }
+ if (!sym->attr.codimension)
+ {
+ gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+ sym->name);
+ return MATCH_ERROR;
+ }
+ }
+
if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ || gfc_peek_ascii_char () == '[' || sym->attr.codimension
|| (sym->attr.dimension && !sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (primary, NULL)
&& !(gfc_matching_procptr_assignment
tail->type = REF_ARRAY;
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag);
+ equiv_flag, sym->as ? sym->as->corank : 0);
if (m != MATCH_YES)
return m;
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
if (m != MATCH_YES)
return m;
}
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+ component->as->corank);
if (m != MATCH_YES)
return m;
}
m = gfc_match_array_ref (&tail->u.ar,
component->ts.u.derived->components->as,
- equiv_flag);
+ equiv_flag,
+ component->ts.u.derived->components->as->corank);
if (m != MATCH_YES)
return m;
}
}
}
+ /* F2008, C727. */
+ if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+ {
+ gfc_error ("Coindexed procedure-pointer component at %C");
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
break;
case AR_ELEMENT:
- allocatable = pointer = 0;
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0)
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
if (m == MATCH_ERROR)
goto cleanup;
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component '%s' in "
+ "structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+
+
/* If not explicitly a parent constructor, gather up the components
and build one. */
if (comp && comp == sym->components
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
+static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
/* F2003, C1272 (3). */
if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
- && gfc_impure_variable (cons->expr->symtree->n.sym))
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
{
t = FAILURE;
- gfc_error ("Invalid expression in the derived type constructor for pointer "
- "component '%s' at %L in PURE procedure", comp->name,
- &cons->expr->where);
+ gfc_error ("Invalid expression in the derived type constructor for "
+ "pointer component '%s' at %L in PURE procedure",
+ comp->name, &cons->expr->where);
}
}
gfc_expr *e;
int save_need_full_assumed_size;
gfc_component *comp;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
}
}
}
+
+ /* Fortran 2008, C1237. */
+ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ "component", &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
+ if (expr->value.function.isym && expr->value.function.isym->inquiry)
+ inquiry_argument = true;
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+
if (resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args) == FAILURE)
+ {
+ inquiry_argument = false;
return FAILURE;
+ }
+ inquiry_argument = false;
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
{
mpz_t last_value;
+ if (ar->dimen_type[i] == DIMEN_STAR)
+ {
+ gcc_assert (ar->stride[i] == NULL);
+ /* This implies [*] as [*:] and [*:3] are not possible. */
+ if (ar->start[i] == NULL)
+ {
+ gcc_assert (ar->end[i] == NULL);
+ return SUCCESS;
+ }
+ }
+
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
case DIMEN_VECTOR:
break;
+ case DIMEN_STAR:
case DIMEN_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld < %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->lower[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld > %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->upper[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
return FAILURE;
}
+ /* ar->codimen == 0 is a local array. */
+ if (as->corank != ar->codimen && ar->codimen != 0)
+ {
+ gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+ &ar->where, ar->codimen, as->corank);
+ return FAILURE;
+ }
+
for (i = 0; i < as->rank; i++)
if (check_dimension (i, ar, as) == FAILURE)
return FAILURE;
+ /* Local access has no coarray spec. */
+ if (ar->codimen != 0)
+ for (i = as->rank; i < as->rank + as->corank; i++)
+ {
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ {
+ gfc_error ("Coindex of codimension %d must be a scalar at %L",
+ i + 1 - as->rank, &ar->where);
+ return FAILURE;
+ }
+ if (check_dimension (i, ar, as) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
int i, check_scalar;
gfc_expr *e;
- for (i = 0; i < ar->dimen; i++)
+ for (i = 0; i < ar->dimen + ar->codimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
}
}
+ if (ar->type == AR_FULL && ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
/* If the reference type is unknown, figure out what kind it is. */
if (ar->type == AR_UNKNOWN)
switch (ref->u.ar.type)
{
case AR_FULL:
+ /* Coarray scalar. */
+ if (ref->u.ar.as->rank == 0)
+ {
+ current_part_dimension = 0;
+ break;
+ }
+ /* Fall through. */
case AR_SECTION:
current_part_dimension = 1;
break;
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
t = FAILURE;
+ /* F2008, C617 and C1229. */
+ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+ && gfc_is_coindexed (e))
+ {
+ gfc_ref *ref, *ref2 = NULL;
+
+ if (e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT)
+ ref2 = ref;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ break;
+ }
+
+ for ( ; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ break;
+
+ /* Expression itself is coindexed object. */
+ if (ref == NULL)
+ {
+ gfc_component *c;
+ c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+ for ( ; c; c = c->next)
+ if (c->attr.allocatable && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Coindexed object with polymorphic allocatable "
+ "subcomponent at %L", &e->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
return t;
}
of f03 OOP. As soon as vtables are in place and contain pointers
to methods, this will no longer be necessary. */
static gfc_expr *list_e;
-static void check_class_members (gfc_symbol *);
+static gfc_try check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
check_members (gfc_symbol *derived)
{
if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
+ (void) check_class_members (derived);
}
-static void
+static gfc_try
check_class_members (gfc_symbol *derived)
{
gfc_expr *e;
{
gfc_error ("no typebound available procedure named '%s' at %L",
e->value.compcall.name, &e->where);
- return;
+ return FAILURE;
}
/* If we have to match a passed class member, force the actual
if (e->value.compcall.base_object == NULL)
e->value.compcall.base_object = extract_compcall_passed_object (e);
+ if (e->value.compcall.base_object == NULL)
+ return FAILURE;
+
if (!derived->attr.abstract)
{
e->value.compcall.base_object->ts.type = BT_DERIVED;
/* Burrow down into grandchildren types. */
if (derived->f2k_derived)
gfc_traverse_ns (derived->f2k_derived, check_members);
+
+ return SUCCESS;
}
class_try = SUCCESS;
fcn_flag = true;
list_e = gfc_copy_expr (e);
- check_class_members (derived);
+
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
class_try = SUCCESS;
fcn_flag = false;
list_e = gfc_copy_expr (code->expr1);
- check_class_members (derived);
+
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
class_try = (resolve_typebound_call (code) == SUCCESS)
? class_try : FAILURE;
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
+ bool inquiry_save;
if (e == NULL)
return SUCCESS;
+ /* inquiry_argument only applies to variables. */
+ inquiry_save = inquiry_argument;
+ if (e->expr_type != EXPR_VARIABLE)
+ inquiry_argument = false;
+
switch (e->expr_type)
{
case EXPR_OP:
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
+ inquiry_argument = inquiry_save;
+
return t;
}
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
+ /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+ checking of coarrays. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+
+ if (ref && ref->type == REF_ARRAY)
+ ref->u.ar.in_allocate = true;
+
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
+ codimension = attr.codimension;
}
else
{
allocatable = sym->ts.u.derived->components->attr.allocatable;
pointer = sym->ts.u.derived->components->attr.pointer;
dimension = sym->ts.u.derived->components->attr.dimension;
+ codimension = sym->ts.u.derived->components->attr.codimension;
is_abstract = sym->ts.u.derived->components->attr.abstract;
}
else
allocatable = sym->attr.allocatable;
pointer = sym->attr.pointer;
dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
break;
case REF_COMPONENT:
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("Coindexed allocatable object at %L",
+ &e->where);
+ goto failure;
+ }
+
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
allocatable = c->ts.u.derived->components->attr.allocatable;
pointer = c->ts.u.derived->components->attr.pointer;
dimension = c->ts.u.derived->components->attr.dimension;
+ codimension = c->ts.u.derived->components->attr.codimension;
is_abstract = c->ts.u.derived->components->attr.abstract;
}
else
allocatable = c->attr.allocatable;
pointer = c->attr.pointer;
dimension = c->attr.dimension;
+ codimension = c->attr.codimension;
is_abstract = c->attr.abstract;
}
break;
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
- return FAILURE;
+ goto failure;
}
/* Some checks for the SOURCE tag. */
{
gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where);
- return FAILURE;
+ goto failure;
}
/* Check F03:C632 and restriction following Note 6.18. */
if (code->expr3->rank > 0
&& conformable_arrays (code->expr3, e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind)
gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
&e->where, &code->expr3->where);
- return FAILURE;
+ goto failure;
}
}
else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
"type-spec or SOURCE=", sym->name, &e->where);
- return FAILURE;
+ goto failure;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
sym->name, &e->where);
- return FAILURE;
+ goto failure;
}
if (!code->expr3)
}
}
- if (pointer || dimension == 0)
- return SUCCESS;
+ if (pointer || (dimension == 0 && codimension == 0))
+ goto success;
/* Make sure the next-to-last reference node is an array specification. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
+ if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ || (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
- return FAILURE;
+ goto failure;
}
/* Make sure that the array section reference makes sense in the
ar = &ref2->u.ar;
+ if (codimension && ar->codimen == 0)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+
for (i = 0; i < ar->dimen; i++)
{
if (ref2->u.ar.type == AR_ELEMENT)
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
+ case DIMEN_STAR:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
- return FAILURE;
+ goto failure;
}
check_symbols:
-
for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
- return FAILURE;
+ goto failure;
}
}
}
+ for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_ELEMENT
+ || ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ if (i == (ar->dimen + ar->codimen - 1))
+ {
+ gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+ "statement at %L", &e->where);
+ goto failure;
+ }
+ break;
+ }
+
+ if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+ && ar->stride[i] == NULL)
+ break;
+
+ gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+
+ if (codimension)
+ {
+ gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+ "at %L", &e->where);
+ goto failure;
+ }
+
+success:
return SUCCESS;
+
+failure:
+ return FAILURE;
}
static void
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
&& rhs->expr_type == EXPR_VARIABLE
- && gfc_impure_variable (rhs->symtree->n.sym))
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ {
+ /* F2008, C1283. */
+ if (gfc_is_coindexed (rhs))
+ gfc_error ("Coindexed expression at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure",
+ &rhs->where);
+ else
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
{
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &rhs->where);
+ gfc_error ("Assignment to coindexed variable at %L in a PURE "
+ "procedure", &rhs->where);
return rval;
}
}
/* F03:7.4.1.2. */
+ /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
+ and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
if (lhs->ts.type == BT_CLASS)
{
gfc_error ("Variable must not be polymorphic in assignment at %L",
return false;
}
+ /* F2008, Section 7.2.1.2. */
+ if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+ {
+ gfc_error ("Coindexed variable must not be have an allocatable ultimate "
+ "component in assignment at %L", &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
for (c = sym->components; c != NULL; c = c->next)
{
/* F2008, C442. */
- if (c->attr.codimension
- && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
+ if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
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, C528. */
+ /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
else if (sym->attr.codimension && !sym->attr.allocatable
- && sym->as->cotype == AS_DEFERRED)
+ && sym->as && sym->as->cotype == AS_DEFERRED)
gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
"deferred shape", sym->name, &sym->declared_at);
else if (sym->attr.codimension && sym->attr.allocatable
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex",
+ sym->name, where);
+ return FAILURE;
+ }
+
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
gfc_se indexse;
gfc_se tmpse;
+ if (ar->dimen == 0)
+ return;
+
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
{
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+ || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
prev_ref = ref;
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
+ /* Return if this is a scalar coarray. */
+ if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+ {
+ gcc_assert (expr->symtree->n.sym->attr.codimension);
+ return false;
+ }
+ else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+ {
+ gcc_assert (prev_ref->u.c.component->attr.codimension);
+ return false;
+ }
+
if (!prev_ref)
allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
continue;
ar = &ref->u.ar;
+
+ if (ar->as->rank == 0)
+ {
+ /* Scalar coarray. */
+ continue;
+ }
+
switch (ar->type)
{
case AR_ELEMENT:
new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.codimension = sym->attr.codimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
break;
case GFC_ISYM_SIZE:
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
/* TODO These implementations of lbound and ubound do not limit if
the size < 0, according to F95's 13.14.53 and 13.14.113. */
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+2010-04-09 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * gfortran.dg/coarray_7.f90: New test.
+ * gfortran.dg/coarray_8.f90: New test.
+
2010-04-08 Bud Davis <bdavis9659@sbcglobal.net>
PR fortran/28039
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+program test
+ implicit none
+ type t3
+ integer, allocatable :: a
+ end type t3
+ type t4
+ type(t3) :: xt3
+ end type t4
+ type t
+ integer, pointer :: ptr
+ integer, allocatable :: alloc(:)
+ end type t
+ type(t), target :: i[*]
+ type(t), allocatable :: ca[:]
+ type(t4), target :: tt4[*]
+ type(t4), allocatable :: ca2[:]
+ integer, volatile :: volat[*]
+ integer, asynchronous :: async[*]
+ integer :: caf1[1,*], caf2[*]
+ allocate(i%ptr)
+ call foo(i%ptr)
+ call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" }
+ call bar(i%ptr)
+ call bar(i[1]%ptr) ! OK, value of ptr target
+ call bar(i[1]%alloc(1)) ! OK
+ call typeDummy(i) ! OK
+ call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy2(ca) ! OK
+ call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy3(tt4%xt3) ! OK
+ call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." }
+ call typeDummy4(ca2) ! OK
+ call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." }
+! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in)
+! is not possible
+
+ call asyn(volat)
+ call asyn(async)
+ call asyn(volat[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+ call asyn(async[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+
+ call coarray(caf1) ! rank mismatch; OK, for non allocatable coarrays
+ call coarray(caf2)
+ call coarray(caf2[1]) ! { dg-error "must be a coarray" }
+ call ups(i)
+ call ups(i[1]) ! { dg-error "with ultimate pointer component" }
+ call ups(i%ptr)
+ call ups(i[1]%ptr) ! OK - passes target not pointer
+contains
+ subroutine asyn(a)
+ integer, intent(in), asynchronous :: a
+ end subroutine asyn
+ subroutine bar(a)
+ integer :: a
+ end subroutine bar
+ subroutine foo(a)
+ integer, pointer :: a
+ end subroutine foo
+ subroutine coarray(a)
+ integer :: a[*]
+ end subroutine coarray
+ subroutine typeDummy(a)
+ type(t) :: a
+ end subroutine typeDummy
+ subroutine typeDummy2(a)
+ type(t),allocatable :: a
+ end subroutine typeDummy2
+ subroutine typeDummy3(a)
+ type(t3) :: a
+ end subroutine typeDummy3
+ subroutine typeDummy4(a)
+ type(t4), allocatable :: a
+ end subroutine typeDummy4
+end program test
+
+
+subroutine alloc()
+type t
+ integer, allocatable :: a(:)
+end type t
+type(t), save :: a[*]
+type(t), allocatable :: b(:)[:], C[:]
+
+allocate(b(1)) ! { dg-error "Coarray specification" }
+allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" }
+allocate(c[*]) ! { dg-error "Sorry" }
+allocate(b(3)[5:*]) ! { dg-error "Sorry" }
+allocate(a%a(5)) ! OK
+end subroutine alloc
+
+
+subroutine dataPtr()
+ integer, save, target :: a[*]
+ data a/5/ ! OK
+ data a[1]/5/ ! { dg-error "cannot have a coindex" }
+ type t
+ integer, pointer :: p
+ end type t
+ type(t), save :: x[*]
+
+ type t2
+ integer :: a(1)
+ end type t2
+ type(t2) y
+ data y%a/4/
+
+
+ x[1]%p => a ! { dg-error "shall not have a coindex" }
+ x%p => a[1] ! { dg-error "shall not have a coindex" }
+end subroutine dataPtr
+
+
+subroutine test3()
+implicit none
+type t
+ integer :: a(1)
+end type t
+type(t), save :: x[*]
+data x%a/4/
+
+ integer, save :: y(1)[*] !(1)
+ call sub(x(1:1)[1]) ! { dg-error "Rank mismatch" }
+contains
+ subroutine sub(a) ! { dg-error "shall not have codimensions with deferred shape" }
+ integer :: a(:)[:]
+ end subroutine sub
+end subroutine test3
+
+
+subroutine test4()
+ integer, save :: i[*]
+ integer :: j
+ call foo(i)
+ call foo(j) ! { dg-error "must be a coarray" }
+contains
+ subroutine foo(a)
+ integer :: a[*]
+ end subroutine foo
+end subroutine test4
+
+
+subroutine allocateTest()
+ implicit none
+ real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c
+ integer :: n, q
+ n = 1
+ q = 1
+ allocate(a(n,n)[q,*]) ! { dg-error "Sorry" }
+ allocate(b(n,n)[q,*]) ! { dg-error "Sorry" }
+ allocate(c(n,n)[q,*]) ! { dg-error "Sorry" }
+end subroutine allocateTest
+
+
+subroutine testAlloc3
+implicit none
+integer, allocatable :: a(:,:,:)[:,:]
+integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
+integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
+integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
+
+allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" }
+allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(d(1,2)[3,*]) ! { dg-error "Sorry" }
+allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" }
+allocate(f(1,2)[3,*]) ! { dg-error "Sorry" }
+end subroutine testAlloc3
+
+
+subroutine testAlloc4()
+ implicit none
+ type co_double_3
+ double precision, allocatable :: array(:)
+ end type co_double_3
+ type(co_double_3),save, codimension[*] :: work
+ allocate(work%array(1))
+ print *, size(work%array)
+end subroutine testAlloc4
+
+subroutine test5()
+ implicit none
+ integer, save :: i[*]
+ print *, i[*] ! { dg-error "Coindex of codimension 1 must be a scalar" }
+end subroutine test5
+
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+module mod2
+ implicit none
+ type t
+ procedure(sub), pointer :: ppc
+ contains
+ procedure :: tbp => sub
+ end type t
+ type t2
+ class(t), allocatable :: poly
+ end type t2
+contains
+ subroutine sub(this)
+ class(t), intent(in) :: this
+ end subroutine sub
+end module mod2
+
+subroutine procTest(y,z)
+ use mod2
+ implicit none
+ type(t), save :: x[*]
+ type(t) :: y[*]
+ type(t2) :: z[*]
+
+ x%ppc => sub
+ call x%ppc() ! OK
+ call x%tbp() ! OK
+ call x[1]%tbp ! OK, not polymorphic
+ ! Invalid per C726
+ call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+ y%ppc => sub
+ call y%ppc() ! OK
+ call y%tbp() ! OK
+ call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj.
+ call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+ ! Invalid per C1229
+ z%poly%ppc => sub
+ call z%poly%ppc() ! OK
+ call z%poly%tbp() ! OK
+ call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" }
+ call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" }
+end subroutine procTest
+
+
+module m
+ type t1
+ integer, pointer :: p
+ end type t1
+ type t2
+ integer :: i
+ end type t2
+ type t
+ integer, allocatable :: a[:]
+ type(t1), allocatable :: b[:]
+ type(t2), allocatable :: c[:]
+ end type t
+contains
+ pure subroutine p2(x)
+ integer, intent(inout) :: x
+ end subroutine p2
+ pure subroutine p3(x)
+ integer, pointer :: x
+ end subroutine p3
+ pure subroutine p1(x)
+ type(t), intent(inout) :: x
+ integer, target :: tgt1
+ x%a = 5
+ x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" }
+ x%b%p => tgt1
+ x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+ x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" }
+ x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+ x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" }
+ call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" }
+ call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" }
+ end subroutine p1
+ subroutine nonPtr()
+ type(t1), save :: a[*]
+ type(t2), save :: b[*]
+ integer, target :: tgt1
+ a%p => tgt1
+ a[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+ a%p => a[2]%p ! { dg-error "shall not have a coindex" }
+ a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+ call p2 (b[1]%i) ! OK
+ call p2 (a[1]%p) ! OK - pointer target and not pointer
+ end subroutine nonPtr
+end module m
+
+
+module mmm3
+ type t
+ integer, allocatable :: a(:)
+ end type t
+contains
+ subroutine assign(x)
+ type(t) :: x[*]
+ allocate(x%a(3))
+ x%a = [ 1, 2, 3]
+ x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong
+ ! (no reallocate on assignment)
+ end subroutine assign
+ subroutine assign2(x,y)
+ type(t),allocatable :: x[:]
+ type(t) :: y
+ x = y
+ x[1] = y ! { dg-error "must not be have an allocatable ultimate component" }
+ end subroutine assign2
+end module mmm3
+
+
+module mmm4
+ implicit none
+contains
+ subroutine t1(x)
+ integer :: x(1)
+ end subroutine t1
+ subroutine t3(x)
+ character :: x(*)
+ end subroutine t3
+ subroutine t2()
+ integer, save :: x[*]
+ integer, save :: y(1)[*]
+ character(len=20), save :: z[*]
+
+ call t1(x) ! { dg-error "Rank mismatch" }
+ call t1(x[1]) ! { dg-error "Rank mismatch" }
+
+ call t1(y(1)) ! OK
+ call t1(y(1)[1]) ! { dg-error "Rank mismatch" }
+
+ call t3(z) ! OK
+ call t3(z[1]) ! { dg-error "Rank mismatch" }
+ end subroutine t2
+end module mmm4
+
+
+subroutine tfgh()
+ integer :: i(2)
+ DATA i/(i, i=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+ do i = 1, 5 ! { dg-error "cannot be a sub-component" }
+ end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh
+
+subroutine tfgh2()
+ integer, save :: x[*]
+ integer :: i(2)
+ DATA i/(x, x=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+ do x = 1, 5 ! { dg-error "cannot be a coarray" }
+ end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh2
+
+
+subroutine f4f4()
+ type t
+ procedure(), pointer, nopass :: ppt => null()
+ end type t
+ external foo
+ type(t), save :: x[*]
+ x%ppt => foo
+ x[1]%ppt => foo ! { dg-error "shall not have a coindex" }
+end subroutine f4f4
+
+
+subroutine corank()
+ integer, allocatable :: a[:,:]
+ call one(a) ! OK
+ call two(a) ! { dg-error "Corank mismatch in argument" }
+contains
+ subroutine one(x)
+ integer :: x[*]
+ end subroutine one
+ subroutine two(x)
+ integer, allocatable :: x[:]
+ end subroutine two
+end subroutine corank
+
+subroutine assign42()
+ integer, allocatable :: z(:)[:]
+ z(:)[1] = z
+end subroutine assign42
+
+! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } }
OSDN Git Service
