WARNING: This is a draft patch! Not all things work, but also no regressions are to be expected. 2010-05-03 Tobias Burnus WARNING: THE CHANGELOG IS INCOMPLETE! PR fortran/18918 * simplify.c (gfc_simplify_lbound,gfc_simplify_this_image, gfc_simplify_ubound): Allow non-constant bounds. * 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. A) THIS_IMAGE/UCOBOUND/LCOBOUND *without* DIM= do not work -------------------------------------------------------------------------- ! TEST CASE (causes segfault "Invalid read of size 2" in ! gfc_conv_loop_setup (trans-array.c:3665)): ! integer, allocatable :: a(:)[:,:,:] print *, ucobound(a) end -------------------------------------------------------------------------- fortran/simplify.c | 43 +-------- fortran/trans-array.c | 134 ++++++++++++++++++++++-------- fortran/trans-intrinsic.c | 154 +++++++++++++++++++++++++++++++++-- fortran/trans-types.c | 13 ++ fortran/trans.h | 4 testsuite/gfortran.dg/coarray_13.f90 | 76 ++++++++++++++++- 6 files changed, 341 insertions(+), 83 deletions(-) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index a40cec1..ad9d36c 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 * @@ -5478,7 +5469,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) { @@ -5497,8 +5488,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]; } } @@ -5523,10 +5513,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); @@ -5536,18 +5525,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; } @@ -5560,16 +5540,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 e20406c..a20ae55 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -523,7 +523,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) @@ -535,17 +535,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; + } } } } @@ -1759,7 +1764,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 +1987,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 +2757,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 +2794,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 +2896,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 +3016,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 +3037,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 +3046,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 +3085,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 +3121,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 +3130,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) { case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: loop->dimen = ss->data.info.dimen; + loop->codimen = ss->data.info.codimen; default: break; @@ -3149,7 +3161,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: @@ -3572,7 +3587,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; @@ -4340,7 +4355,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; @@ -5319,7 +5354,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; @@ -5331,6 +5366,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) @@ -5343,7 +5381,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"); @@ -5468,6 +5506,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); @@ -6454,7 +6504,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; @@ -6470,11 +6520,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; @@ -6484,6 +6536,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; @@ -6496,7 +6556,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; @@ -6516,8 +6576,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: @@ -6529,8 +6592,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-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1ffe284..20ecee3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -820,6 +820,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. */ @@ -856,9 +857,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. */ @@ -883,7 +884,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); @@ -895,7 +896,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, @@ -991,6 +992,133 @@ 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) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!arg2->expr); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->expr == expr); + gfc_advance_se_ss_chain (se); + bound = se->loop->loopvar[0]; + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + se->loop->from[0]); +/* FIXME:*/ + cond = boolean_false_node; + } + 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]); + } + 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)); + else + cond = boolean_false_node; + } + + 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); + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ +/* if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + {*/ + 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); +/* } + else + { + gfc_ss_info *info; + gfc_ss *secss; + +*/ /* Find the SS for the array section. */ +/* secss = ss; + while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION) + secss = secss->next; + + gcc_assert (secss != gfc_ss_terminator); + info = &secss->data.info; + +*/ /* Get the descriptor for the array. */ +/* gfc_conv_ss_descriptor (&se->pre, secss, 0); + + desc = info->descriptor; + resbound = info->start[1]; + } +*/ + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + { + 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); + +/* gfc_fatal_error ("Not yet implemented: %s for coarray with non-constant " + "cobounds at %L", expr->value.function.isym->name, + &expr->where); */ +} + + +static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree arg; @@ -5339,6 +5467,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) { @@ -5459,6 +5591,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) { @@ -5478,6 +5614,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; @@ -5562,8 +5702,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) @@ -5664,7 +5804,9 @@ 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: 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 31a250d..a59dbff 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 = GFC_ARRAY_ASSUMED_SHAPE; return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, @@ -1636,7 +1647,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *) ggc_alloc_cleared (sizeof (struct lang_type)); - GFC_TYPE_ARRAY_RANK (fat_type) = dimen; + GFC_TYPE_ARRAY_RANK (fat_type) = dimen + 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 8e2b688..b9ca63b 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. */ @@ -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; diff --git a/gcc/testsuite/gfortran.dg/coarray_13.f90 b/gcc/testsuite/gfortran.dg/coarray_13.f90 index bbd1ad4..d6ac916 100644 --- a/gcc/testsuite/gfortran.dg/coarray_13.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_13.f90 @@ -2,18 +2,86 @@ ! { 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() +! call three(3,A) + allocate(B(3)[-4:*]) + 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() ! <<< FAILS + 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() ! <<< FAILS + end subroutine two + + +! subroutine three(n,A) +! integer :: n +! integer :: A(3)[n:*] +! +! print *, lcobound(A,dim=1),':=',n !! TEST +! +! if (this_image(A,dim=1) /= n) call abort() ! << FAILS +! if (lcobound (A,dim=1) /= n) call abort() ! << FAILS +! if (ucobound (A,dim=1) /= n) call abort() ! << FAILS +! 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 +! print *, this_image(a,dim=i), 5 ! <<< FAILS +! print *, lcobound(a,dim=i),5 ! <<< FAILS +! print *, ubound(a,dim=i),7 ! <<< FAILS +! +! i = 2 +! print *, this_image(a,dim=i),4 ! <<< FAILS +! print *, lbound(a,dim=i),4 ! <<< FAILS +! print *, ubound(a,dim=i),4 ! <<< FAILS +! end subroutine five end program test