diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 110 | ||||
| -rw-r--r-- | gcc/fortran/data.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 86 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 103 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 9 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 148 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 48 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 321 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 5 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_7.f90 | 194 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_8.f90 | 191 |
16 files changed, 1212 insertions, 93 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0b6bfae..96efee0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,39 @@ +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 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 4282fd1..5ceca4b 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src) 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; @@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init) 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) @@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init) 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]); @@ -110,6 +122,12 @@ end_element: /* 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]); @@ -119,6 +137,10 @@ end_element: return MATCH_ERROR; } +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + return MATCH_YES; } @@ -128,14 +150,23 @@ end_element: 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) { @@ -144,34 +175,73 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) 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; } @@ -460,8 +530,8 @@ coarray: 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 (;;) diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 0d04d65..16cd899 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -289,6 +289,14 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) 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", diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index b376192..a9cd984 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -570,6 +570,62 @@ cleanup: /************************ 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. */ @@ -1603,6 +1659,8 @@ variable_decl (int elem) 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; @@ -3050,27 +3108,27 @@ match_attr_spec (void) 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; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d85f23c..2200a80 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3205,6 +3205,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) 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) { @@ -3369,6 +3383,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) 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; } @@ -3642,7 +3670,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, 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)) @@ -3836,3 +3865,75 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) 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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f4f5d52..3668df4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1444,13 +1444,15 @@ extern gfc_interface_info current_interface; 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; @@ -2642,6 +2644,11 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *); 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; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5b01af9..9dd797b 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1445,6 +1445,65 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, 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; @@ -1453,10 +1512,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || 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)", @@ -1474,7 +1536,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, - (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. */ @@ -1984,6 +2047,57 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 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) { @@ -2367,6 +2481,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) 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; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 70bf9ac..2709de7 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -949,6 +949,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) locus start; match m; + e1 = e2 = e3 = NULL; + /* Match the start of an iterator without affecting the symbol table. */ start = gfc_current_locus; @@ -962,9 +964,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) 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) { @@ -979,6 +984,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) 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); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 7a0f847..67e7741 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -216,7 +216,7 @@ match gfc_match_init_expr (gfc_expr **); /* 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. */ diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 113729f..34b6874 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1746,7 +1746,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 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 @@ -1761,7 +1779,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 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; @@ -1771,7 +1789,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 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; } @@ -1881,7 +1899,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 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; } @@ -1894,7 +1913,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, 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; } @@ -1949,6 +1969,13 @@ check_substring: } } + /* 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; } @@ -2023,7 +2050,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; case AR_ELEMENT: - allocatable = pointer = 0; + /* Handle coarrays. */ + if (ref->u.ar.dimen > 0) + allocatable = pointer = 0; break; case AR_UNKNOWN: @@ -2349,6 +2378,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, 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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3ec454e..5e9b25c 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -77,6 +77,9 @@ static int current_entry_id; /* 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) { @@ -932,12 +935,13 @@ resolve_structure_cons (gfc_expr *expr) /* 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); } } @@ -1319,7 +1323,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; gfc_component *comp; - + for (; arg; arg = arg->next) { e = arg->expr; @@ -1549,6 +1553,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } } } + + /* 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; @@ -2590,11 +2603,19 @@ resolve_function (gfc_expr *expr) 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) @@ -3755,6 +3776,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { 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. */ @@ -3763,21 +3795,36 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) 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; } @@ -3897,10 +3944,32 @@ compare_spec_to_ref (gfc_array_ref *ar) 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; } @@ -4069,7 +4138,7 @@ resolve_array_ref (gfc_array_ref *ar) 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; @@ -4103,6 +4172,9 @@ resolve_array_ref (gfc_array_ref *ar) } } + 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) @@ -4307,6 +4379,13 @@ resolve_ref (gfc_expr *expr) 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; @@ -4576,6 +4655,47 @@ resolve_procedure: 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; } @@ -5163,7 +5283,7 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) 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; @@ -5172,11 +5292,11 @@ static void 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; @@ -5193,7 +5313,7 @@ check_class_members (gfc_symbol *derived) { 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 @@ -5203,6 +5323,9 @@ check_class_members (gfc_symbol *derived) 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; @@ -5240,6 +5363,8 @@ check_class_members (gfc_symbol *derived) /* Burrow down into grandchildren types. */ if (derived->f2k_derived) gfc_traverse_ns (derived->f2k_derived, check_members); + + return SUCCESS; } @@ -5393,7 +5518,9 @@ resolve_typebound_function (gfc_expr* e) 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; @@ -5453,7 +5580,9 @@ resolve_typebound_subroutine (gfc_code *code) 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; @@ -5585,10 +5714,16 @@ gfc_try 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: @@ -5676,6 +5811,8 @@ gfc_resolve_expr (gfc_expr *e) if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) fixup_charlen (e); + inquiry_argument = inquiry_save; + return t; } @@ -6123,6 +6260,7 @@ static gfc_try 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; @@ -6134,8 +6272,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* 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. */ @@ -6153,6 +6300,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) attr = gfc_expr_attr (e); pointer = attr.pointer; dimension = attr.dimension; + codimension = attr.codimension; } else { @@ -6161,6 +6309,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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 @@ -6168,6 +6317,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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) @@ -6183,12 +6333,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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 @@ -6196,6 +6355,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; + codimension = c->attr.codimension; is_abstract = c->attr.abstract; } break; @@ -6212,7 +6372,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); - return FAILURE; + goto failure; } /* Some checks for the SOURCE tag. */ @@ -6223,13 +6383,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { 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) @@ -6237,7 +6397,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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) @@ -6245,14 +6405,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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) @@ -6285,16 +6445,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } } - 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 @@ -6302,6 +6463,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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) @@ -6322,13 +6490,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) 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; @@ -6345,12 +6513,46 @@ check_symbols: 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 @@ -8031,17 +8233,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && 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", @@ -8049,6 +8269,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) 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; } @@ -10462,8 +10690,8 @@ 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)) + 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); @@ -11351,9 +11579,9 @@ resolve_symbol (gfc_symbol *sym) 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 @@ -11548,6 +11776,13 @@ check_data_variable (gfc_data_variable *var, locus *where) 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) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 75516ce..cbdd8b9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, gfc_se indexse; gfc_se tmpse; + if (ar->dimen == 0) + return; + /* Handle scalarized references separately. */ if (ar->type != AR_ELEMENT) { @@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) /* 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; } @@ -3966,6 +3970,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) 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 @@ -6361,6 +6377,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) continue; ar = &ref->u.ar; + + if (ar->as->rank == 0) + { + /* Scalar coarray. */ + continue; + } + switch (ar->type) { case AR_ELEMENT: diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7e95ce1..10716b7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1848,6 +1848,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, 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; @@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) break; case GFC_ISYM_SIZE: - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8a4fc08..5b77482 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +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 diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90 new file mode 100644 index 0000000..8cd295d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_7.f90 @@ -0,0 +1,194 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/coarray_8.f90 b/gcc/testsuite/gfortran.dg/coarray_8.f90 new file mode 100644 index 0000000..6ceba8b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_8.f90 @@ -0,0 +1,191 @@ +! { 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" } } |