2010-07-03 Tobias Burnus Mikael Morin PR fortran/18918 * array.c (gfc_match_array_ref): Better diagnostic for too few codimensions. * iresolve.c (resolve_bound, gfc_resolve_lbound, gfc_resolve_lcobound, gfc_resolve_this_image, gfc_resolve_ubound, gfc_resolve_ucobound): Fix corank handling. * simplify.c (gfc_simplify_lbound,gfc_simplify_this_image, gfc_simplify_ubound): Allow non-constant bounds. WARNING: THE CHANGELOG IS INCOMPLETE FOR: * fortran/trans-types.c (...): * fortran/trans.h (...): * trans-array.c (...): * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2. (conv_intrinsic_cobound): New function. (gfc_conv_intrinsic_function): Call it. (gfc_walk_intrinsic_function): Handle ucobound and lcobound. (gfc_add_intrinsic_ss_code): Update comment. 2010-07-03 Tobias Burnus * gfortran.dg/coarray_13.f90: Add coarray descriptor diagnostic check. * gfortran.dg/coarray_13.f90: Add checks for run-time bounds. fortran/array.c | 6 + fortran/iresolve.c | 27 ++++-- fortran/simplify.c | 43 +-------- fortran/trans-array.c | 154 ++++++++++++++++++++++++++--------- fortran/trans-decl.c | 16 +++ fortran/trans-intrinsic.c | 135 +++++++++++++++++++++++++++++- fortran/trans-types.c | 34 +++++++ fortran/trans.h | 9 +- testsuite/gfortran.dg/coarray_10.f90 | 8 + testsuite/gfortran.dg/coarray_13.f90 | 92 ++++++++++++++++++++ 10 files changed, 427 insertions(+), 97 deletions(-) diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 64816f2..e3c9d59 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -234,7 +234,11 @@ coarray: if (gfc_match_char (',') != MATCH_YES) { - gfc_error ("Invalid form of coarray reference at %C"); + if (gfc_match_char ('*') == MATCH_YES) + gfc_error ("Unexpected '*' for codimension %d of %d at %C", + ar->codimen + 1, corank); + else + gfc_error ("Invalid form of coarray reference at %C"); return MATCH_ERROR; } } diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 8f764ef..a13a099 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -122,7 +122,7 @@ resolve_mask_arg (gfc_expr *mask) static void resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, - const char *name) + const char *name, bool coarray) { f->ts.type = BT_INTEGER; if (kind) @@ -134,7 +134,20 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, { f->rank = 1; f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); + if (coarray) + { + int corank; + gfc_ref *ref; + corank = array->symtree->n.sym->as + ? array->symtree->n.sym->as->corank : 0; + for (ref = array->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + + mpz_init_set_ui (f->shape[0], corank); + } + else + mpz_init_set_ui (f->shape[0], array->rank); } f->value.function.name = xstrdup (name); @@ -1268,14 +1281,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED, void gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__lbound"); + resolve_bound (f, array, dim, kind, "__lbound", false); } void gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__lcobound"); + resolve_bound (f, array, dim, kind, "__lcobound", true); } @@ -2401,7 +2414,7 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, void gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) { - resolve_bound (f, array, dim, NULL, "__this_image"); + resolve_bound (f, array, dim, NULL, "__this_image", true); } @@ -2540,14 +2553,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) void gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__ubound"); + resolve_bound (f, array, dim, kind, "__ubound", false); } void gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - resolve_bound (f, array, dim, kind, "__ucobound"); + resolve_bound (f, array, dim, kind, "__ucobound", true); } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7356625..63eca64 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3057,16 +3057,7 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - gfc_expr *e; - /* return simplify_cobound (array, dim, kind, 0);*/ - - e = simplify_cobound (array, dim, kind, 0); - if (e != NULL) - return e; - - gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant " - "cobounds at %L", &array->where); - return &gfc_bad_expr; + return simplify_cobound (array, dim, kind, 0); } gfc_expr * @@ -5504,7 +5495,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) as = ref->u.ar.as; if (as->type == AS_DEFERRED) - goto not_implemented; /* return NULL;*/ + return NULL; if (dim == NULL) { @@ -5523,8 +5514,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) for (j = 0; j < d; j++) gfc_free_expr (bounds[j]); - if (bounds[d] == NULL) - goto not_implemented; + return bounds[d]; } } @@ -5549,10 +5539,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) } else { - gfc_expr *e; /* A DIM argument is specified. */ if (dim->expr_type != EXPR_CONSTANT) - goto not_implemented; /*return NULL;*/ + return NULL; d = mpz_get_si (dim->value.integer); @@ -5562,18 +5551,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) return &gfc_bad_expr; } - /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ - e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); - if (e != NULL) - return e; - else - goto not_implemented; + return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, + true); } - -not_implemented: - gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " - "cobounds at %L", &coarray->where); - return &gfc_bad_expr; } @@ -5586,16 +5566,7 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - gfc_expr *e; - /* return simplify_cobound (array, dim, kind, 1);*/ - - e = simplify_cobound (array, dim, kind, 1); - if (e != NULL) - return e; - - gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " - "cobounds at %L", &array->where); - return &gfc_bad_expr; + return simplify_cobound (array, dim, kind, 1); } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eb8e75..cd051a8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -522,7 +522,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, tree tmp; if (as && as->type == AS_EXPLICIT) - for (dim = 0; dim < se->loop->dimen; dim++) + for (dim = 0; dim < se->loop->dimen + se->loop->codimen; dim++) { n = se->loop->order[dim]; if (se->loop->to[n] == NULL_TREE) @@ -534,17 +534,22 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, gfc_add_block_to_block (&se->post, &tmpse.post); lower = fold_convert (gfc_array_index_type, tmpse.expr); - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->loop->to[n] = tmp; + if (se->loop->codimen == 0 + || dim < se->loop->dimen + se->loop->codimen - 1) + { + /* ...and the upper bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + upper = fold_convert (gfc_array_index_type, tmpse.expr); + + /* Set the upper bound of the loop to UPPER - LOWER. */ + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, + lower); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->loop->to[n] = tmp; + } } } } @@ -798,6 +803,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); size = gfc_evaluate_now (size, pre); } + for (n = info->dimen; n < info->dimen + info->codimen; n++) + { + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_index_zero_node); + if (n < info->dimen + info->codimen - 1) + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]); + } /* Get the size of the array. */ @@ -1759,7 +1771,7 @@ gfc_trans_constant_array_constructor (gfc_loopinfo * loop, info->data = gfc_build_addr_expr (NULL_TREE, tmp); info->offset = gfc_index_zero_node; - for (i = 0; i < info->dimen; i++) + for (i = 0; i < info->dimen + info->codimen; i++) { info->delta[i] = gfc_index_zero_node; info->start[i] = gfc_index_zero_node; @@ -1982,7 +1994,7 @@ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info) int n; int dim; - for (n = 0; n < loop->dimen; n++) + for (n = 0; n < loop->dimen + loop->codimen; n++) { dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR @@ -2752,7 +2764,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) gcc_assert (!loop->array_parameter); - for (dim = loop->dimen - 1; dim >= 0; dim--) + for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--) { n = loop->order[dim]; @@ -2789,7 +2801,7 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)) == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) - && n == loop->dimen - 1) + && n == loop->dimen + loop->codimen - 1) { /* We create an OMP_FOR construct for the outermost scalarized loop. */ init = make_tree_vec (1); @@ -2891,7 +2903,7 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) pblock = body; /* Generate the loops. */ - for (dim = 0; dim < loop->dimen; dim++) + for (dim = 0; dim < loop->dimen + loop->codimen; dim++) { n = loop->order[dim]; gfc_trans_scalarized_loop_end (loop, n, pblock); @@ -3011,11 +3023,12 @@ gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n, + bool coarray) { gfc_expr *start; gfc_expr *end; - gfc_expr *stride; + gfc_expr *stride = NULL; tree desc; gfc_se se; gfc_ss_info *info; @@ -3031,7 +3044,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) /* We use a zero-based index to access the vector. */ info->start[n] = gfc_index_zero_node; info->end[n] = gfc_index_zero_node; - info->stride[n] = gfc_index_one_node; + if (!coarray) + info->stride[n] = gfc_index_one_node; return; } @@ -3039,7 +3053,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) desc = info->descriptor; start = info->ref->u.ar.start[dim]; end = info->ref->u.ar.end[dim]; - stride = info->ref->u.ar.stride[dim]; + if (!coarray) + stride = info->ref->u.ar.stride[dim]; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ @@ -3077,9 +3092,9 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre); /* Calculate the stride. */ - if (stride == NULL) + if (!coarray && stride == NULL) info->stride[n] = gfc_index_one_node; - else + else if (!coarray) { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); @@ -3113,6 +3128,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_SS_FUNCTION: case GFC_SS_COMPONENT: loop->dimen = ss->data.info.dimen; + loop->codimen = ss->data.info.codimen; break; /* As usual, lbound and ubound are exceptions!. */ @@ -3121,7 +3137,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) { case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_THIS_IMAGE: loop->dimen = ss->data.info.dimen; + loop->codimen = ss->data.info.codimen; default: break; @@ -3149,7 +3169,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); for (n = 0; n < ss->data.info.dimen; n++) - gfc_conv_section_startstride (loop, ss, n); + gfc_conv_section_startstride (loop, ss, n, false); + for (n = ss->data.info.dimen; + n < ss->data.info.dimen + ss->data.info.codimen; n++) + gfc_conv_section_startstride (loop, ss, n, true); break; case GFC_SS_INTRINSIC: @@ -3158,7 +3181,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_THIS_IMAGE: break; + default: continue; } @@ -3544,6 +3571,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, loop->temp_ss->data.temp.type = base_type; loop->temp_ss->string_length = dest->string_length; loop->temp_ss->data.temp.dimen = loop->dimen; + loop->temp_ss->data.temp.codimen = loop->codimen; loop->temp_ss->next = gfc_ss_terminator; gfc_add_ss_to_loop (loop, loop->temp_ss); } @@ -3572,7 +3600,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) mpz_t i; mpz_init (i); - for (n = 0; n < loop->dimen; n++) + for (n = 0; n < loop->dimen + loop->codimen; n++) { loopspec[n] = NULL; dynamic[n] = false; @@ -3660,7 +3688,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* Set the extents of this range. */ cshape = loopspec[n]->shape; - if (cshape && INTEGER_CST_P (info->start[n]) + if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[n]) && INTEGER_CST_P (info->stride[n])) { loop->from[n] = info->start[n]; @@ -3706,9 +3734,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[n])) + if (n < loop->dimen && integer_onep (info->stride[n])) info->delta[n] = gfc_index_zero_node; - else + else if (n < loop->dimen) { /* Set the delta for this section. */ info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre); @@ -4303,7 +4331,27 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, size = stride; } - +/* FIXME: probably does not make much sense. */ + for (dim = as->rank; dim < as->rank + as->corank; dim++) + { + /* Evaluate non-constant array bound expressions. */ + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (as->lower[dim] && !INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, lbound, se.expr); + } + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (as->upper[dim] && !INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, ubound, se.expr); + } + } gfc_trans_vla_type_sizes (sym, pblock); *poffset = offset; @@ -5217,6 +5265,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) se->string_length = loop.temp_ss->string_length; loop.temp_ss->data.temp.dimen = loop.dimen; + loop.temp_ss->data.temp.codimen = loop.codimen; gfc_add_ss_to_loop (&loop, loop.temp_ss); } @@ -5280,7 +5329,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) limits will be the limits of the section. A function may decide to repack the array to speed up access, but we're not bothered about that here. */ - int dim, ndim; + int dim, ndim, codim; tree parm; tree parmtype; tree stride; @@ -5292,6 +5341,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); + codim = (info->ref && info->ref->u.ar.type == AR_FULL) + ? info->ref->u.ar.as->corank : 0; + desc = info->descriptor; gcc_assert (secss && secss != gfc_ss_terminator); if (se->direct_byref) @@ -5304,7 +5356,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Otherwise make a new one. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); @@ -5429,6 +5481,18 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) dim++; } + for (n = ndim; n < ndim + codim; n++) + { + from = loop.from[dim]; + to = loop.to[dim]; + gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_rank_cst[dim], from); + if (n < ndim + codim - 1) + gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_rank_cst[dim], to); + dim++; + } + if (se->data_not_needed) gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node); @@ -6438,7 +6502,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) switch (ar->type) { case AR_ELEMENT: - for (n = 0; n < ar->dimen; n++) + for (n = 0; n < ar->dimen + ar->codimen; n++) { newss = gfc_get_ss (); newss->type = GFC_SS_SCALAR; @@ -6454,11 +6518,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) newss->expr = expr; newss->next = ss; newss->data.info.dimen = ar->as->rank; + newss->data.info.codimen = ar->as->corank; newss->data.info.ref = ref; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ ar->dimen = ar->as->rank; + ar->codimen = ar->as->corank; for (n = 0; n < ar->dimen; n++) { newss->data.info.dim[n] = n; @@ -6468,6 +6534,14 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) gcc_assert (ar->end[n] == NULL); gcc_assert (ar->stride[n] == NULL); } + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + { + newss->data.info.dim[n] = n; + ar->dimen_type[n] = DIMEN_RANGE; + + gcc_assert (ar->start[n] == NULL); + gcc_assert (ar->end[n] == NULL); + } ss = newss; break; @@ -6480,7 +6554,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) newss->data.info.ref = ref; /* We add SS chains for all the subscripts in the section. */ - for (n = 0; n < ar->dimen; n++) + for (n = 0; n < ar->dimen + ar->codimen; n++) { gfc_ss *indexss; @@ -6500,8 +6574,11 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) case DIMEN_RANGE: /* We don't add anything for sections, just remember this dimension for later. */ - newss->data.info.dim[newss->data.info.dimen] = n; - newss->data.info.dimen++; + newss->data.info.dim[newss->data.info.dimen + newss->data.info.codimen] = n; + if (n < ar->dimen) + newss->data.info.dimen++; + else + newss->data.info.codimen++; break; case DIMEN_VECTOR: @@ -6513,8 +6590,11 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) indexss->next = gfc_ss_terminator; indexss->loop_chain = gfc_ss_terminator; newss->data.info.subscript[n] = indexss; - newss->data.info.dim[newss->data.info.dimen] = n; - newss->data.info.dimen++; + newss->data.info.dim[newss->data.info.dimen+newss->data.info.codimen] = n; + if (n < ar->dimen) + newss->data.info.dimen++; + else + newss->data.info.codimen++; break; default: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 1c7226c..570c808 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -711,6 +711,22 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym) TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1; } } + for (dim = GFC_TYPE_ARRAY_RANK (type); + dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++) + { + if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) + { + GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); + TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1; + } + /* Don't try to use the unknown ubound for the last coarray dimension. */ + if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE + && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1) + { + GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); + TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1; + } + } if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) { GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 06fd538..4d40beb 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -795,6 +795,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) se->expr = fold_convert (type, res); } + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -831,9 +832,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) else { /* use the passed argument. */ - gcc_assert (arg->next->expr); + gcc_assert (arg2->expr); gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); gfc_add_block_to_block (&se->pre, &argse.pre); bound = argse.expr; /* Convert from one based to zero based. */ @@ -858,7 +859,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) hi = TREE_INT_CST_HIGH (bound); low = TREE_INT_CST_LOW (bound); - if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + if (hi || low < 0 || low >= arg->expr->rank) gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " "dimension index", upper ? "UBOUND" : "LBOUND", &expr->where); @@ -870,7 +871,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) bound = gfc_evaluate_now (bound, &se->pre); cond = fold_build2 (LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + tmp = gfc_rank_cst[arg->expr->rank]; tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -966,6 +967,110 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) static void +conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + gfc_se argse; + gfc_ss *ss; + tree bound, resbound, resbound2, desc, cond; + tree type; + gfc_array_spec * as; + gfc_ref *ref; + int corank; + + gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND + || expr->value.function.isym->id == GFC_ISYM_UCOBOUND + || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE); + + arg = expr->value.function.actual; + arg2 = arg->next; + + gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); + + corank = arg->expr->symtree->n.sym->as + ? arg->expr->symtree->n.sym->as->corank : 0; + for (ref = arg->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + + if (se->ss) + { + mpz_t mpz_rank; + tree tree_rank; + + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!arg2->expr); + gcc_assert (corank > 0); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->expr == expr); + + mpz_init_set_ui (mpz_rank, arg->expr->rank); + tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind); + + bound = se->loop->loopvar[0]; + bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound, + se->ss->data.info.delta[0]); + bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound, + tree_rank); + gfc_advance_se_ss_chain (se); + } + else + { + /* use the passed argument. */ + gcc_assert (arg2->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + bound = argse.expr; + /* Substract 1 to get to zero based and add dimensions. */ + switch (arg->expr->rank) + { + case 0: + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + gfc_index_one_node); + case 1: + break; + default: + bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound, + gfc_rank_cst[arg->expr->rank - 1]); + } + } + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + gcc_assert (as); + + ss = gfc_walk_expr (arg->expr); + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); + + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + resbound = gfc_conv_descriptor_lbound_get (desc, bound); + + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + { + cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank + corank - 1)); + resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); + se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, + resbound, resbound2); + } + else + se->expr = resbound; + + /* TODO: Add codimension checking; arg->expr should have the + required corank information as init expression. */ + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); +} + + +static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree arg, cabs; @@ -5159,6 +5264,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 0); break; + case GFC_ISYM_LCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_TRANSPOSE: if (se->ss && se->ss->useflags) { @@ -5279,6 +5388,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); break; + case GFC_ISYM_THIS_IMAGE: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_TRANSFER: if (se->ss && se->ss->useflags) { @@ -5298,6 +5411,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 1); break; + case GFC_ISYM_UCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_XOR: gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); break; @@ -5374,6 +5491,9 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) { case GFC_ISYM_UBOUND: case GFC_ISYM_LBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_THIS_IMAGE: break; default: @@ -5382,8 +5502,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) } -/* UBOUND and LBOUND intrinsics with one parameter are expanded into code - inside the scalarization loop. */ +/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter + are expanded into code inside the scalarization loop. */ static gfc_ss * gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) @@ -5484,7 +5604,10 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, switch (isym->id) { case GFC_ISYM_LBOUND: + case GFC_ISYM_LCOBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_THIS_IMAGE: return gfc_walk_intrinsic_bound (ss, expr); case GFC_ISYM_TRANSFER: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index f4e78c2..d5739f3 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1220,6 +1220,17 @@ gfc_build_array_type (tree type, gfc_array_spec * as, ubound[n] = gfc_conv_array_bound (as->upper[n]); } + for (n = as->rank; n < as->rank + as->corank; n++) + { + if (as->lower[n] == NULL) + lbound[n] = gfc_index_one_node; + else + lbound[n] = gfc_conv_array_bound (as->lower[n]); + + if (n < as->rank + as->corank - 1) + ubound[n] = gfc_conv_array_bound (as->upper[n]); + } + if (as->type == AS_ASSUMED_SHAPE) akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT : GFC_ARRAY_ASSUMED_SHAPE; @@ -1292,7 +1303,7 @@ gfc_get_dtype (tree type) if (GFC_TYPE_ARRAY_DTYPE (type)) return GFC_TYPE_ARRAY_DTYPE (type); - rank = GFC_TYPE_ARRAY_RANK (type); + rank = GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); etype = gfc_get_element_type (type); switch (TREE_CODE (etype)) @@ -1448,6 +1459,25 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, if (packed == PACKED_NO || packed == PACKED_PARTIAL) known_stride = 0; } + for (n = as->rank; n < as->rank + as->corank; n++) + { + expr = as->lower[n]; + if (expr->expr_type == EXPR_CONSTANT) + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + else + tmp = NULL_TREE; + GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; + + expr = as->upper[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + else + tmp = NULL_TREE; + if (n < as->rank + as->corank - 1) + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; + } if (known_offset) { @@ -1466,6 +1496,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; GFC_TYPE_ARRAY_RANK (type) = as->rank; + GFC_TYPE_ARRAY_CORANK (type) = as->corank; GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; range = build_range_type (gfc_array_index_type, gfc_index_zero_node, NULL_TREE); @@ -1625,6 +1656,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); GFC_TYPE_ARRAY_RANK (fat_type) = dimen; + GFC_TYPE_ARRAY_CORANK (fat_type) = codimen; GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; GFC_TYPE_ARRAY_AKIND (fat_type) = akind; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 02361fc..064d644 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -92,7 +92,7 @@ gfc_se; typedef struct gfc_ss_info { - int dimen; + int dimen, codimen; /* The ref that holds information on this section. */ gfc_ref *ref; /* The descriptor of this array. */ @@ -186,7 +186,7 @@ typedef struct gfc_ss { /* The rank of the temporary. May be less than the rank of the assigned expression. */ - int dimen; + int dimen, codimen; tree type; } temp; @@ -219,7 +219,7 @@ typedef struct gfc_loopinfo stmtblock_t pre; stmtblock_t post; - int dimen; + int dimen, codimen; /* All the SS involved with this loop. */ gfc_ss *ss; @@ -638,7 +638,7 @@ enum gfc_array_kind variable-sized in some other frontends. Due to gengtype deficiency the GTY options of such types have to agree across all frontends. */ struct GTY((variable_size)) lang_type { - int rank; + int rank, corank; enum gfc_array_kind akind; tree lbound[GFC_MAX_DIMENSIONS]; tree ubound[GFC_MAX_DIMENSIONS]; @@ -692,6 +692,7 @@ struct GTY((variable_size)) lang_decl { #define GFC_TYPE_ARRAY_STRIDE(node, dim) \ (TYPE_LANG_SPECIFIC(node)->stride[dim]) #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank) +#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank) #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size) #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset) #define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind) diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 7a50c89..b44b3e6 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -24,5 +24,11 @@ subroutine this_image_check() j = this_image(dim=3) ! { dg-error "DIM argument without ARRAY argument" } i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" } i = image_index(z, 2) ! { dg-error "must be a rank one array" } - end subroutine this_image_check + + +subroutine rank_mismatch() + implicit none + integer, allocatable:: A(:)[:,:,:] + allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" } +end subroutine rank_mismatch diff --git a/gcc/testsuite/gfortran.dg/coarray_13.f90 b/gcc/testsuite/gfortran.dg/coarray_13.f90 index bbd1ad4..f96b895 100644 --- a/gcc/testsuite/gfortran.dg/coarray_13.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_13.f90 @@ -2,18 +2,102 @@ ! { dg-options "-fcoarray=single" } ! ! Coarray support -- allocatable array coarrays +! -- intrinsic procedures ! PR fortran/18918 ! PR fortran/43931 ! program test implicit none + integer,allocatable :: B(:)[:] + call one() + call two() + allocate(B(3)[-4:*]) + call three(3,B) + call four(B) + call five() contains subroutine one() integer, allocatable :: a(:)[:,:,:] allocate(a(1)[-4:9,8,4:*]) - end subroutine one - subroutine four(C) - integer, allocatable :: C(:)[:] - end subroutine four + + if (this_image(a,dim=1) /= -4_8) call abort() + if (lcobound (a,dim=1) /= -4_8) call abort() + if (ucobound (a,dim=1) /= 9_8) call abort() + + if (this_image(a,dim=2) /= 1_8) call abort() + if (lcobound (a,dim=2) /= 1_8) call abort() + if (ucobound (a,dim=2) /= 8_8) call abort() + + if (this_image(a,dim=3) /= 4_8) call abort() + if (lcobound (a,dim=3) /= 4_8) call abort() + if (ucobound (a,dim=3) /= 4_8) call abort() + + if (any(this_image(a) /= [-4_8, 1_8, 4_8])) call abort() + if (any(lcobound (a) /= [-4_8, 1_8, 4_8])) call abort() + if (any(ucobound (a) /= [9_8, 8_8, 4_8])) call abort() + end subroutine one + + subroutine two() + integer, allocatable :: a(:)[:,:,:] + allocate(a(1)[-4:9,8,4:*]) + + if (this_image(a,dim=1) /= -4) call abort() + if (lcobound (a,dim=1) /= -4) call abort() + if (ucobound (a,dim=1) /= 9) call abort() + + if (this_image(a,dim=2) /= 1) call abort() + if (lcobound (a,dim=2) /= 1) call abort() + if (ucobound (a,dim=2) /= 8) call abort() + + if (this_image(a,dim=3) /= 4) call abort() + if (lcobound (a,dim=3) /= 4) call abort() + if (ucobound (a,dim=3) /= 4) call abort() + + if (any(this_image(a) /= [-4, 1, 4])) call abort() + if (any(lcobound (a) /= [-4, 1, 4])) call abort() + if (any(ucobound (a) /= [9, 8, 4])) call abort() + end subroutine two + + subroutine three(n,A) + integer :: n + integer :: A(3)[n:*] + + A(1) = 42 + if (A(1) /= 42) call abort() + A(1)[n] = -42 + if (A(1)[n] /= -42) call abort() + + if (this_image(A,dim=1) /= n) call abort() + if (lcobound (A,dim=1) /= n) call abort() + if (ucobound (A,dim=1) /= n) call abort() + + if (any(this_image(A) /= n)) call abort() + if (any(lcobound (A) /= n)) call abort() + if (any(ucobound (A) /= n)) call abort() + end subroutine three + + subroutine four(A) + integer, allocatable :: A(:)[:] + if (this_image(A,dim=1) /= -4_8) call abort() + if (lcobound (A,dim=1) /= -4_8) call abort() + if (ucobound (A,dim=1) /= -4_8) call abort() + end subroutine four + + subroutine five() + integer, save :: foo(2)[5:7,4:*] + integer :: i + + i = 1 + foo(1)[5,4] = 42 + if (foo(1)[5,4] /= 42) call abort() + if (this_image(foo,dim=i) /= 5) call abort() + if (lcobound(foo,dim=i) /= 5) call abort() + if (ucobound(foo,dim=i) /= 7) call abort() + + i = 2 + if (this_image(foo,dim=i) /= 4) call abort() + if (lcobound(foo,dim=i) /= 4) call abort() + if (ucobound(foo,dim=i) /= 4) call abort() + end subroutine five end program test