* [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch @ 2011-03-31 22:20 Tobias Burnus 2011-04-03 15:03 ` Tobias Burnus 0 siblings, 1 reply; 4+ messages in thread From: Tobias Burnus @ 2011-03-31 22:20 UTC (permalink / raw) To: gcc patches, gfortran [-- Attachment #1: Type: text/plain, Size: 1479 bytes --] Hi all, attached you find a draft patch for implementing the run-time support for THIS_IMAGE(coarray), LCOBOUND and UCOBOUND where the cobounds (or the "dim=" argument) are not known at the compile time. There are two cases where the bounds are not known: a) For allocatable coarrays: integer, allocatable :: coarray(:)[:,:] allocate(coarray(3)[7,*]) b) For cobounds, which are variables such as integer, intent(inout) :: coarray(:)[0:n, 1:*] For those coarray the bounds need to be saved in the array descriptor (or for the second variant, in the variable declaration). That's what this patch does. I am sure there are still some issues, but it should not cause issues for no-coarrays. Note: The current implementation is for -fcoarray=single, for -fcoarray=lib you get wrong results (except for LCOBOUND). For -fcoarray=lib, the last dim of UCOBOUND is currently the one of the last-dim LCOBOUND, the proper value (for num_images > 1) should have "(size - 1) / num_images()" added, where "size" is the size of all cobounds except for the last. And THIS_IMAGE(coarray) is currently the same as LCOBOUND, which is only correct for this_image() == 1. The patch has been loosely tested - and an earlier version was bootstrapped and regtested; currently, another regtest is running. I will re-read the patch and write a changelog, but if you want you can already review - or test - it; I do not expect many (if any) changes for the final patch. Tobias [-- Attachment #2: coarray_intrinsics_runtime_draft6.diff --] [-- Type: text/x-patch, Size: 45871 bytes --] b/gcc/fortran/check.c | 10 + b/gcc/fortran/expr.c | 7 b/gcc/fortran/gfortran.h | 2 b/gcc/fortran/interface.c | 26 +-- b/gcc/fortran/resolve.c | 41 +++-- b/gcc/fortran/simplify.c | 43 ----- b/gcc/fortran/trans-array.c | 205 ++++++++++++++++++++------- b/gcc/fortran/trans-decl.c | 16 ++ b/gcc/fortran/trans-intrinsic.c | 150 +++++++++++++++++++ b/gcc/fortran/trans-types.c | 32 ++++ b/gcc/fortran/trans.h | 9 - b/gcc/testsuite/gfortran.dg/coarray_10.f90 | 6 b/gcc/testsuite/gfortran.dg/coarray_13.f90 | 140 +++++++++++++++++- gcc/gcc/testsuite/gfortran.dg/coarray_15.f90 | 46 ++++++ 14 files changed, 597 insertions(+), 136 deletions(-) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index adb4b95..bb56122 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -219,9 +219,15 @@ is_coarray (gfc_expr *e) { if (ref->type == REF_COMPONENT) coarray = ref->u.c.component->attr.codimension; - else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 - || ref->u.ar.codimen != 0) + else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0) coarray = false; + else if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + int n; + for (n = 0; n < ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + coarray = false; + } } return coarray; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 58b6036..38f748b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return true; + { + int n; + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return true; + } return false; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index eec737c..495923a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1486,7 +1486,7 @@ extern gfc_interface_info current_interface; enum gfc_array_ref_dimen_type { - DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN + DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN }; typedef struct gfc_array_ref diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index b0b74c1..00fd24a 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1564,8 +1564,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_ref *last = NULL; if (actual->expr_type != EXPR_VARIABLE - || (actual->ref == NULL - && !actual->symtree->n.sym->attr.codimension)) + || !gfc_expr_attr (actual).codimension) { if (where) gfc_error ("Actual argument to '%s' at %L must be a coarray", @@ -1573,15 +1572,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (gfc_is_coindexed (actual)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and not coindexed", 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) { @@ -1595,14 +1595,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, 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) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1fef22b..01999e5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4157,6 +4157,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) switch (ar->dimen_type[i]) { case DIMEN_VECTOR: + case DIMEN_THIS_IMAGE: break; case DIMEN_STAR: @@ -4324,7 +4325,8 @@ compare_spec_to_ref (gfc_array_ref *ar) if (ar->codimen != 0) for (i = as->rank; i < as->rank + as->corank; i++) { - if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate + && ar->dimen_type[i] != DIMEN_THIS_IMAGE) { gfc_error ("Coindex of codimension %d must be a scalar at %L", i + 1 - as->rank, &ar->where); @@ -4334,6 +4336,14 @@ compare_spec_to_ref (gfc_array_ref *ar) return FAILURE; } + if (as->corank && ar->codimen == 0) + { + int n; + ar->codimen = as->corank; + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + ar->dimen_type[n] = DIMEN_THIS_IMAGE; + } + return SUCCESS; } @@ -6848,12 +6858,14 @@ 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; - } + if (codimension) + for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) + if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } for (i = 0; i < ar->dimen; i++) { @@ -6876,6 +6888,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: case DIMEN_STAR: + case DIMEN_THIS_IMAGE: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); goto failure; @@ -12501,18 +12514,18 @@ check_data_variable (gfc_data_variable *var, locus *where) has_pointer = sym->attr.pointer; + if (gfc_is_coindexed (e)) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name, + where); + return FAILURE; + } + for (ref = e->ref; ref; ref = ref->next) { 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/simplify.c b/gcc/fortran/simplify.c index 69edad8..2a99445 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3632,16 +3632,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 * @@ -6338,7 +6329,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) { @@ -6357,8 +6348,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]; } } @@ -6383,10 +6373,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); @@ -6396,18 +6385,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; } @@ -6420,16 +6400,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 ac08c42..0f7b017 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -562,7 +562,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, tree tmp; if (as && as->type == AS_EXPLICIT) - for (n = 0; n < se->loop->dimen; n++) + for (n = 0; n < se->loop->dimen + se->loop->codimen; n++) { dim = se->ss->data.info.dim[n]; gcc_assert (dim < as->rank); @@ -576,18 +576,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_loc (input_location, MINUS_EXPR, + if (se->loop->codimen == 0 + || n < 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_loc (input_location, MINUS_EXPR, gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->loop->to[n] = tmp; + tmp = gfc_evaluate_now (tmp, &se->pre); + se->loop->to[n] = tmp; + } } } } @@ -885,6 +889,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, 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. */ @@ -1777,7 +1788,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; @@ -2018,7 +2029,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 @@ -2452,6 +2463,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, gcc_assert (ar->type != AR_ELEMENT); switch (ar->dimen_type[dim]) { + case DIMEN_THIS_IMAGE: + gcc_unreachable (); + break; case DIMEN_ELEMENT: /* Elemental dimension. */ gcc_assert (info->subscript[dim] @@ -2813,7 +2827,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]; @@ -2967,7 +2981,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); @@ -3043,11 +3057,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim, + bool coarray, bool coarray_last) { gfc_expr *start; gfc_expr *end; - gfc_expr *stride; + gfc_expr *stride = NULL; tree desc; gfc_se se; gfc_ss_info *info; @@ -3060,8 +3075,9 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { /* We use a zero-based index to access the vector. */ info->start[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; info->end[dim] = NULL; + if (!coarray) + info->stride[dim] = gfc_index_one_node; return; } @@ -3069,7 +3085,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) 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. */ @@ -3091,25 +3108,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ - if (end) + if (!coarray_last) { - /* Specified section start. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, end, gfc_array_index_type); - gfc_add_block_to_block (&loop->pre, &se.pre); - info->end[dim] = se.expr; - } - else - { - /* No upper bound specified so use the bound of the array. */ - info->end[dim] = gfc_conv_array_ubound (desc, dim); + if (end) + { + /* Specified section start. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, end, gfc_array_index_type); + gfc_add_block_to_block (&loop->pre, &se.pre); + info->end[dim] = se.expr; + } + else + { + /* No upper bound specified so use the bound of the array. */ + info->end[dim] = gfc_conv_array_ubound (desc, dim); + } + info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); } - info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); /* Calculate the stride. */ - if (stride == NULL) + if (!coarray && stride == NULL) info->stride[dim] = gfc_index_one_node; - else + else if (!coarray) { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); @@ -3143,6 +3163,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!. */ @@ -3152,6 +3173,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: loop->dimen = ss->data.info.dimen; + loop->codimen = 0; + break; + + 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; @@ -3164,7 +3193,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* We should have determined the rank of the expression by now. If not, that's bad news. */ - gcc_assert (loop->dimen != 0); + gcc_assert (loop->dimen + loop->codimen != 0); /* Loop over all the SS in the chain. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) @@ -3179,7 +3208,14 @@ 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, ss->data.info.dim[n]); + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], + false, false); + for (n = ss->data.info.dimen; + n < ss->data.info.dimen + ss->data.info.codimen; n++) + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true, + n == ss->data.info.dimen + + ss->data.info.codimen -1); + break; case GFC_SS_INTRINSIC: @@ -3188,7 +3224,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; } @@ -3697,6 +3737,7 @@ temporary: 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); } @@ -3725,7 +3766,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; @@ -3739,7 +3780,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) info = &ss->data.info; dim = info->dim[n]; - if (loopspec[n] != NULL) + if (loopspec[n] != NULL /*|| n >= loop->dimen*/) { specinfo = &loopspec[n]->data.info; spec_dim = specinfo->dim[n]; @@ -3807,7 +3848,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) known lower bound known upper bound */ - else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) + else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) + || n >= loop->dimen) loopspec[n] = ss; else if (integer_onep (info->stride[dim]) && !integer_onep (specinfo->stride[spec_dim])) @@ -3833,7 +3875,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[dim]) + if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim]) && INTEGER_CST_P (info->stride[dim])) { loop->from[n] = info->start[dim]; @@ -3877,9 +3919,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[dim])) + if (n < loop->dimen && integer_onep (info->stride[dim])) info->delta[dim] = gfc_index_zero_node; - else + else if (n < loop->dimen) { /* Set the delta for this section. */ info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); @@ -4663,7 +4705,26 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, size = stride; } - + 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; @@ -5626,6 +5687,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); } @@ -5689,7 +5751,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; @@ -5701,6 +5763,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; if (se->direct_byref && !se->byref_noassign) { @@ -5712,7 +5777,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"); @@ -5845,6 +5910,26 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_rank_cst[dim], stride); } + for (n = ndim; n < ndim + codim; n++) + { + /* look for the corresponding scalarizer dimension: dim. */ + for (dim = 0; dim < ndim + codim; dim++) + if (info->dim[dim] == n) + break; + + /* loop exited early: the DIM being looked for has been found. */ + gcc_assert (dim < ndim + codim); + + 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); @@ -7311,7 +7396,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; @@ -7327,11 +7412,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 = 0; 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; @@ -7341,6 +7428,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; @@ -7353,12 +7448,14 @@ 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; switch (ar->dimen_type[n]) { + case DIMEN_THIS_IMAGE: + continue; case DIMEN_ELEMENT: /* Add SS for elemental (scalar) subscripts. */ gcc_assert (ar->start[n]); @@ -7373,8 +7470,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: @@ -7386,8 +7486,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 a0bbe53..cc6fced 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -767,6 +767,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 fa3e4c2..da62dae 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -932,6 +932,7 @@ trans_num_images (gfc_se * se) se->expr = gfort_gvar_caf_num_images; } + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -969,9 +970,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. */ @@ -1117,6 +1118,128 @@ 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, tmp; + tree type; + gfc_array_spec * as; + 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 = gfc_get_corank (arg->expr); + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + gcc_assert (as); + + ss = gfc_walk_expr (arg->expr); + gcc_assert (ss != gfc_ss_terminator); + ss->data.info.codimen = corank; + 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; + + 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; + + if (INTEGER_CST_P (bound)) + { + int hi, low; + + hi = TREE_INT_CST_HIGH (bound); + low = TREE_INT_CST_LOW (bound); + if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))) + gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " + "dimension index", expr->value.function.isym->name, + &expr->where); + } + else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + bound = gfc_evaluate_now (bound, &se->pre); + cond = fold_build2 (LT_EXPR, boolean_type_node, + bound, build_int_cst (TREE_TYPE (bound), 1)); + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; + tmp = fold_build2 (GT_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, + gfc_msg_fault); + } + + + /* 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]); + } + } + + 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; + + 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; @@ -5960,6 +6083,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: /* The scalarizer has already been set up for reversed dimension access order ; now we just get the argument value normally. */ @@ -6117,6 +6244,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; @@ -6126,7 +6257,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_THIS_IMAGE: - trans_this_image (se, expr); + if (expr->value.function.actual) + conv_intrinsic_cobound (se, expr); + else + trans_this_image (se, expr); break; case GFC_ISYM_NUM_IMAGES: @@ -6261,6 +6395,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: @@ -6269,8 +6406,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) @@ -6407,7 +6544,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 8ecceea..7e12f08 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1249,6 +1249,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; @@ -1477,6 +1488,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) { @@ -1495,6 +1525,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); @@ -1654,6 +1685,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 19e86bb..543ad52 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -104,7 +104,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. */ @@ -198,7 +198,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; @@ -231,7 +231,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; @@ -713,7 +713,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]; @@ -768,6 +768,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 6ee425d..d32e254 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -44,3 +44,9 @@ subroutine rank_mismatch() A(1)[1,1] = 1 ! { dg-error "Too few codimensions" } A(1)[1,1:1] = 1 ! { dg-error "Too few codimensions" } end subroutine rank_mismatch + +subroutine rank_mismatch2() + implicit none + integer, allocatable:: A(:)[:,:,:] + allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" } +end subroutine rank_mismatch2 diff --git a/gcc/testsuite/gfortran.dg/coarray_13.f90 b/gcc/testsuite/gfortran.dg/coarray_13.f90 index bbd1ad4..2fcc963 100644 --- a/gcc/testsuite/gfortran.dg/coarray_13.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_13.f90 @@ -1,19 +1,149 @@ ! { dg-do run } -! { dg-options "-fcoarray=single" } +! { dg-options "-fcoarray=single -fcheck=bounds" } ! ! 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,1) + call three_a(3,B) + call three_b(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, n2) + integer :: n, n2 + integer :: A(3)[n:*] + + A(1) = 42 + if (A(1) /= 42) call abort() + A(1)[n2] = -42 + if (A(1)[n2] /= -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 three_a(n,A) + integer :: n + integer :: A(3)[n+2:n+5,n-1:*] + + A(1) = 42 + if (A(1) /= 42) call abort() + A(1)[4,n] = -42 + if (A(1)[4,n] /= -42) call abort() + + if (this_image(A,dim=1) /= n+2) call abort() + if (lcobound (A,dim=1) /= n+2) call abort() + if (ucobound (A,dim=1) /= n+5) call abort() + + if (this_image(A,dim=2) /= n-1) call abort() + if (lcobound (A,dim=2) /= n-1) call abort() + if (ucobound (A,dim=2) /= n-1) call abort() + + if (any(this_image(A) /= [n+2,n-1])) call abort() + if (any(lcobound (A) /= [n+2,n-1])) call abort() + if (any(ucobound (A) /= [n+5,n-1])) call abort() + end subroutine three_a + + subroutine three_b(n,A) + integer :: n + integer :: A(-1:3,0:4,-2:5,-4:7)[n+2:n+5,n-1:*] + + A(1,1,1,1) = 42 + if (A(1,1,1,1) /= 42) call abort() + A(1,1,1,1)[4,n] = -42 + if (A(1,1,1,1)[4,n] /= -42) call abort() + + if (this_image(A,dim=1) /= n+2) call abort() + if (lcobound (A,dim=1) /= n+2) call abort() + if (ucobound (A,dim=1) /= n+5) call abort() + + if (this_image(A,dim=2) /= n-1) call abort() + if (lcobound (A,dim=2) /= n-1) call abort() + if (ucobound (A,dim=2) /= n-1) call abort() + + if (any(this_image(A) /= [n+2,n-1])) call abort() + if (any(lcobound (A) /= [n+2,n-1])) call abort() + if (any(ucobound (A) /= [n+5,n-1])) call abort() + end subroutine three_b + + 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 --- /dev/null 2011-03-28 19:44:49.502024685 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_15.f90 2011-03-31 23:33:11.000000000 +0200 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! +! Contributed by John Reid. +! +program ex2 + implicit none + real, allocatable :: z(:)[:] + integer :: image + allocate(z(3)[*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:)[image] = z + end do + end if + sync all + write(*,*) 'z=',z(:),' on image',this_image() + write(*,*) 'z=',z,' on image',this_image() + write(*,*) 'z=',z(1:3)[this_image()],' on image',this_image() + call ex2a() +end + +subroutine ex2a() + implicit none + real, allocatable :: z(:,:)[:,:] + integer :: image + allocate(z(2,2)[1,*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:,:)[1,image] = z + end do + end if + sync all + write(*,*) 'z=',z(:,:),' on image',this_image() + write(*,*) 'z=',z,' on image',this_image() +end subroutine ex2a ^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch 2011-03-31 22:20 [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch Tobias Burnus @ 2011-04-03 15:03 ` Tobias Burnus 2011-04-04 9:44 ` Daniel Kraft 0 siblings, 1 reply; 4+ messages in thread From: Tobias Burnus @ 2011-04-03 15:03 UTC (permalink / raw) To: gcc patches, gfortran [-- Attachment #1: Type: text/plain, Size: 1428 bytes --] Dear all, This patch adds support for THIS_IMAGE(coarray[,dim=]), LCOBOUND and UCOBOUND for bounds only known at run time (be it allocatable arrays, explicit arrays with variables in the explicit bounds or a non-constant value for dim=). For the support, the scalarizer had to be modified and the cobounds had to be saved in the descriptor (and in TYPE_LANG_SPECIFIC(node)). Note: For this patch's THIS_IMAGE and UCOBOUND, the assumption is made that there is only one image (-fcoarray=single). This will be fixed in a later patch. Changes compared to the draft patch (http://gcc.gnu.org/ml/fortran/2011-03/msg00242.html): - New subtest "ex5", which was ICEing with the draft patch - Needed changes to avoid the ICE - Small clean-up of the patch - Added ChangeLog Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: I am not sure that all changes to trans-array.c are required or fully correct. The scalarizer should only be applied to codimensions for THIS_IMAGE/LCOBOUND/UCOBOUND - all other usage should not invoke the codimensions. Side remark: "z", "z(:)", "z(1)" all refer to the local coimage (DIMEN_THIS_IMAGE) - only if "[...]" appears (e.g. "z(:)[2]") a remote image is accessed. This will become relevant for -fcoarray=lib. (At that point, one also needs to make sure that for "z(:)[i] = 5", gfortran does not call the coarray communication library size(z) times but only once.) [-- Attachment #2: coarray_intrinsics_runtime_draft7.diff --] [-- Type: text/x-patch, Size: 49875 bytes --] 2011-04-03 Tobias Burnus <burnus@net-b.de> Mikael Morin <mikael.morin@sfr.fr> PR fortran/18918 * check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE. * expr.c (gfc_is_coindexed): Ditto. * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE. * interface.c (compare_parameter): Use gfc_expr_attr and gfc_is_coindexed. * resolve.c (check_dimension, compare_spec_to_ref, resolve_allocate_expr, check_data_variable): Update for DIMEN_THIS_IMAGE. * simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image, gfc_simplify_ucobound): Allow non-constant bounds. * trans-array.c (gfc_set_loop_bounds_from_array_spec, gfc_trans_create_temp_array, gfc_trans_constant_array_constructor, gfc_set_vector_loop_bounds, gfc_conv_array_index_offset, gfc_start_scalarized_body, gfc_trans_scalarizing_loops, gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride, gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_trans_array_bounds, gfc_conv_expr_descriptor, gfc_walk_variable_expr): Handle codimen. * trans-decl.c (gfc_build_qualified_array): Save cobounds. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2. (conv_intrinsic_cobound): New function. (gfc_conv_intrinsic_function): Call it. (gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle ucobound, lcobound, this_image. * fortran/trans-types.c (gfc_build_array_type): Save cobounds. (gfc_get_dtype): Honour corank. (gfc_get_nodesc_array_type): Save corank and codimensions. (gfc_get_array_type_bounds): Save cobound. * fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item. (gfc_array_kind): Add corank item. (GFC_TYPE_ARRAY_CORANK): New macro. 2011-04-03 Tobias Burnus <burnus@net-b.de> * gfortran.dg/coarray_10.f90: Add coarray descriptor diagnostic check. * gfortran.dg/coarray_13.f90: Add checks for run-time cobounds. * gfortran.dg/coarray_15.f90: New. gcc/fortran/check.c | 10 + gcc/fortran/expr.c | 7 gcc/fortran/gfortran.h | 2 gcc/fortran/interface.c | 26 +-- gcc/fortran/resolve.c | 41 +++-- gcc/fortran/simplify.c | 43 ----- gcc/fortran/trans-array.c | 205 ++++++++++++++++++++------- gcc/fortran/trans-decl.c | 16 ++ gcc/fortran/trans-intrinsic.c | 150 +++++++++++++++++++ gcc/fortran/trans-types.c | 32 ++++ gcc/fortran/trans.h | 9 - gcc/testsuite/gfortran.dg/coarray_10.f90 | 6 gcc/testsuite/gfortran.dg/coarray_13.f90 | 138 +++++++++++++++++- gcc/testsuite/gfortran.dg/coarray_15.f90 | 112 ++++++++++++++ 14 files changed, 660 insertions(+), 137 deletions(-) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index adb4b95..bb56122 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -219,9 +219,15 @@ is_coarray (gfc_expr *e) { if (ref->type == REF_COMPONENT) coarray = ref->u.c.component->attr.codimension; - else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 - || ref->u.ar.codimen != 0) + else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0) coarray = false; + else if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + int n; + for (n = 0; n < ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + coarray = false; + } } return coarray; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 58b6036..38f748b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return true; + { + int n; + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return true; + } return false; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index eec737c..495923a 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1486,7 +1486,7 @@ extern gfc_interface_info current_interface; enum gfc_array_ref_dimen_type { - DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN + DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN }; typedef struct gfc_array_ref diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index b0b74c1..00fd24a 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1564,8 +1564,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_ref *last = NULL; if (actual->expr_type != EXPR_VARIABLE - || (actual->ref == NULL - && !actual->symtree->n.sym->attr.codimension)) + || !gfc_expr_attr (actual).codimension) { if (where) gfc_error ("Actual argument to '%s' at %L must be a coarray", @@ -1573,15 +1572,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (gfc_is_coindexed (actual)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and not coindexed", 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) { @@ -1595,14 +1595,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, 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) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1fef22b..01999e5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4157,6 +4157,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) switch (ar->dimen_type[i]) { case DIMEN_VECTOR: + case DIMEN_THIS_IMAGE: break; case DIMEN_STAR: @@ -4324,7 +4325,8 @@ compare_spec_to_ref (gfc_array_ref *ar) if (ar->codimen != 0) for (i = as->rank; i < as->rank + as->corank; i++) { - if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate + && ar->dimen_type[i] != DIMEN_THIS_IMAGE) { gfc_error ("Coindex of codimension %d must be a scalar at %L", i + 1 - as->rank, &ar->where); @@ -4334,6 +4336,14 @@ compare_spec_to_ref (gfc_array_ref *ar) return FAILURE; } + if (as->corank && ar->codimen == 0) + { + int n; + ar->codimen = as->corank; + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + ar->dimen_type[n] = DIMEN_THIS_IMAGE; + } + return SUCCESS; } @@ -6848,12 +6858,14 @@ 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; - } + if (codimension) + for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) + if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } for (i = 0; i < ar->dimen; i++) { @@ -6876,6 +6888,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: case DIMEN_STAR: + case DIMEN_THIS_IMAGE: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); goto failure; @@ -12501,18 +12514,18 @@ check_data_variable (gfc_data_variable *var, locus *where) has_pointer = sym->attr.pointer; + if (gfc_is_coindexed (e)) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name, + where); + return FAILURE; + } + for (ref = e->ref; ref; ref = ref->next) { 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/simplify.c b/gcc/fortran/simplify.c index 69edad8..2a99445 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3632,16 +3632,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 * @@ -6338,7 +6329,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) { @@ -6357,8 +6348,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]; } } @@ -6383,10 +6373,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); @@ -6396,18 +6385,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; } @@ -6420,16 +6400,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 ac08c42..00c1ff3 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -562,7 +562,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, tree tmp; if (as && as->type == AS_EXPLICIT) - for (n = 0; n < se->loop->dimen; n++) + for (n = 0; n < se->loop->dimen + se->loop->codimen; n++) { dim = se->ss->data.info.dim[n]; gcc_assert (dim < as->rank); @@ -576,18 +576,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_loc (input_location, 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 + || n < 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_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->loop->to[n] = tmp; + } } } } @@ -885,6 +889,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, 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. */ @@ -1777,7 +1788,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; @@ -2018,7 +2029,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 @@ -2452,6 +2463,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, gcc_assert (ar->type != AR_ELEMENT); switch (ar->dimen_type[dim]) { + case DIMEN_THIS_IMAGE: + gcc_unreachable (); + break; case DIMEN_ELEMENT: /* Elemental dimension. */ gcc_assert (info->subscript[dim] @@ -2813,7 +2827,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]; @@ -2967,7 +2981,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); @@ -3043,11 +3057,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim, + bool coarray, bool coarray_last) { gfc_expr *start; gfc_expr *end; - gfc_expr *stride; + gfc_expr *stride = NULL; tree desc; gfc_se se; gfc_ss_info *info; @@ -3060,8 +3075,9 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { /* We use a zero-based index to access the vector. */ info->start[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; info->end[dim] = NULL; + if (!coarray) + info->stride[dim] = gfc_index_one_node; return; } @@ -3069,7 +3085,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) 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. */ @@ -3091,25 +3108,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ - if (end) + if (!coarray_last) { - /* Specified section start. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, end, gfc_array_index_type); - gfc_add_block_to_block (&loop->pre, &se.pre); - info->end[dim] = se.expr; - } - else - { - /* No upper bound specified so use the bound of the array. */ - info->end[dim] = gfc_conv_array_ubound (desc, dim); + if (end) + { + /* Specified section start. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, end, gfc_array_index_type); + gfc_add_block_to_block (&loop->pre, &se.pre); + info->end[dim] = se.expr; + } + else + { + /* No upper bound specified so use the bound of the array. */ + info->end[dim] = gfc_conv_array_ubound (desc, dim); + } + info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); } - info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); /* Calculate the stride. */ - if (stride == NULL) + if (!coarray && stride == NULL) info->stride[dim] = gfc_index_one_node; - else + else if (!coarray) { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); @@ -3143,6 +3163,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!. */ @@ -3152,6 +3173,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: loop->dimen = ss->data.info.dimen; + loop->codimen = 0; + break; + + 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; @@ -3164,7 +3193,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* We should have determined the rank of the expression by now. If not, that's bad news. */ - gcc_assert (loop->dimen != 0); + gcc_assert (loop->dimen + loop->codimen != 0); /* Loop over all the SS in the chain. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) @@ -3179,7 +3208,14 @@ 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, ss->data.info.dim[n]); + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], + false, false); + for (n = ss->data.info.dimen; + n < ss->data.info.dimen + ss->data.info.codimen; n++) + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true, + n == ss->data.info.dimen + + ss->data.info.codimen -1); + break; case GFC_SS_INTRINSIC: @@ -3188,7 +3224,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; } @@ -3697,6 +3737,7 @@ temporary: 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); } @@ -3725,7 +3766,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; @@ -3739,7 +3780,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) info = &ss->data.info; dim = info->dim[n]; - if (loopspec[n] != NULL) + if (loopspec[n] != NULL /*|| n >= loop->dimen*/) { specinfo = &loopspec[n]->data.info; spec_dim = specinfo->dim[n]; @@ -3807,7 +3848,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) known lower bound known upper bound */ - else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) + else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) + || n >= loop->dimen) loopspec[n] = ss; else if (integer_onep (info->stride[dim]) && !integer_onep (specinfo->stride[spec_dim])) @@ -3833,7 +3875,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[dim]) + if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim]) && INTEGER_CST_P (info->stride[dim])) { loop->from[n] = info->start[dim]; @@ -3877,9 +3919,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[dim])) + if (n < loop->dimen && integer_onep (info->stride[dim])) info->delta[dim] = gfc_index_zero_node; - else + else if (n < loop->dimen) { /* Set the delta for this section. */ info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); @@ -4663,7 +4705,26 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, size = stride; } - + 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; @@ -5626,6 +5687,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); } @@ -5689,7 +5751,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; @@ -5712,8 +5774,9 @@ 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, - loop.from, loop.to, 0, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + loop.codimen, loop.from, + loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); } @@ -5744,6 +5807,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) base = NULL_TREE; ndim = info->ref ? info->ref->u.ar.dimen : info->dimen; + codim = info->codimen; for (n = 0; n < ndim; n++) { stride = gfc_conv_array_stride (desc, n); @@ -5845,6 +5909,26 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_rank_cst[dim], stride); } + for (n = ndim; n < ndim + codim; n++) + { + /* look for the corresponding scalarizer dimension: dim. */ + for (dim = 0; dim < ndim + codim; dim++) + if (info->dim[dim] == n) + break; + + /* loop exited early: the DIM being looked for has been found. */ + gcc_assert (dim < ndim + codim); + + 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); @@ -7311,7 +7395,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; @@ -7327,11 +7411,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 = 0; 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 = 0; for (n = 0; n < ar->dimen; n++) { newss->data.info.dim[n] = n; @@ -7341,6 +7427,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->as->corank; 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; @@ -7350,15 +7444,18 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) newss->expr = expr; newss->next = ss; newss->data.info.dimen = 0; + newss->data.info.codimen = 0; 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; switch (ar->dimen_type[n]) { + case DIMEN_THIS_IMAGE: + continue; case DIMEN_ELEMENT: /* Add SS for elemental (scalar) subscripts. */ gcc_assert (ar->start[n]); @@ -7373,8 +7470,9 @@ 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++; break; case DIMEN_VECTOR: @@ -7386,8 +7484,9 @@ 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++; break; default: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index a0bbe53..cc6fced 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -767,6 +767,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 fa3e4c2..a3c2ecd 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -932,6 +932,7 @@ trans_num_images (gfc_se * se) se->expr = gfort_gvar_caf_num_images; } + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -969,9 +970,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. */ @@ -1117,6 +1118,128 @@ 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, tmp; + tree type; + gfc_array_spec * as; + 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 = gfc_get_corank (arg->expr); + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + gcc_assert (as); + + ss = gfc_walk_expr (arg->expr); + gcc_assert (ss != gfc_ss_terminator); + ss->data.info.codimen = corank; + 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; + + 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; + + if (INTEGER_CST_P (bound)) + { + int hi, low; + + hi = TREE_INT_CST_HIGH (bound); + low = TREE_INT_CST_LOW (bound); + if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))) + gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " + "dimension index", expr->value.function.isym->name, + &expr->where); + } + else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + bound = gfc_evaluate_now (bound, &se->pre); + cond = fold_build2 (LT_EXPR, boolean_type_node, + bound, build_int_cst (TREE_TYPE (bound), 1)); + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; + tmp = fold_build2 (GT_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, + gfc_msg_fault); + } + + + /* 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]); + } + } + + 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; + + 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; @@ -5960,6 +6083,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: /* The scalarizer has already been set up for reversed dimension access order ; now we just get the argument value normally. */ @@ -6117,6 +6244,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; @@ -6126,7 +6257,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_THIS_IMAGE: - trans_this_image (se, expr); + if (expr->value.function.actual) + conv_intrinsic_cobound (se, expr); + else + trans_this_image (se, expr); break; case GFC_ISYM_NUM_IMAGES: @@ -6261,6 +6395,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: @@ -6269,8 +6406,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) @@ -6407,7 +6544,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 8ecceea..7e12f08 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1249,6 +1249,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; @@ -1477,6 +1488,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) { @@ -1495,6 +1525,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); @@ -1654,6 +1685,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 19e86bb..543ad52 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -104,7 +104,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. */ @@ -198,7 +198,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; @@ -231,7 +231,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; @@ -713,7 +713,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]; @@ -768,6 +768,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 6ee425d..d32e254 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -44,3 +44,9 @@ subroutine rank_mismatch() A(1)[1,1] = 1 ! { dg-error "Too few codimensions" } A(1)[1,1:1] = 1 ! { dg-error "Too few codimensions" } end subroutine rank_mismatch + +subroutine rank_mismatch2() + implicit none + integer, allocatable:: A(:)[:,:,:] + allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" } +end subroutine rank_mismatch2 diff --git a/gcc/testsuite/gfortran.dg/coarray_13.f90 b/gcc/testsuite/gfortran.dg/coarray_13.f90 index bbd1ad4..1c79a07 100644 --- a/gcc/testsuite/gfortran.dg/coarray_13.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_13.f90 @@ -1,19 +1,149 @@ ! { dg-do run } -! { dg-options "-fcoarray=single" } +! { dg-options "-fcoarray=single -fcheck=bounds" } ! ! 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,1) + call three_a(3,B) + call three_b(3,B) + call four(B) + call five() contains subroutine one() integer, allocatable :: a(:)[:,:,:] allocate(a(1)[-4:9,8,4:*]) + + 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 four(C) - integer, allocatable :: C(:)[:] - end subroutine four + + 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, n2) + integer :: n, n2 + integer :: A(3)[n:*] + + A(1) = 42 + if (A(1) /= 42) call abort() + A(1)[n2] = -42 + if (A(1)[n2] /= -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 three_a(n,A) + integer :: n + integer :: A(3)[n+2:n+5,n-1:*] + + A(1) = 42 + if (A(1) /= 42) call abort() + A(1)[4,n] = -42 + if (A(1)[4,n] /= -42) call abort() + + if (this_image(A,dim=1) /= n+2) call abort() + if (lcobound (A,dim=1) /= n+2) call abort() + if (ucobound (A,dim=1) /= n+5) call abort() + + if (this_image(A,dim=2) /= n-1) call abort() + if (lcobound (A,dim=2) /= n-1) call abort() + if (ucobound (A,dim=2) /= n-1) call abort() + + if (any(this_image(A) /= [n+2,n-1])) call abort() + if (any(lcobound (A) /= [n+2,n-1])) call abort() + if (any(ucobound (A) /= [n+5,n-1])) call abort() + end subroutine three_a + + subroutine three_b(n,A) + integer :: n + integer :: A(-1:3,0:4,-2:5,-4:7)[n+2:n+5,n-1:*] + + A(1,1,1,1) = 42 + if (A(1,1,1,1) /= 42) call abort() + A(1,1,1,1)[4,n] = -42 + if (A(1,1,1,1)[4,n] /= -42) call abort() + + if (this_image(A,dim=1) /= n+2) call abort() + if (lcobound (A,dim=1) /= n+2) call abort() + if (ucobound (A,dim=1) /= n+5) call abort() + + if (this_image(A,dim=2) /= n-1) call abort() + if (lcobound (A,dim=2) /= n-1) call abort() + if (ucobound (A,dim=2) /= n-1) call abort() + + if (any(this_image(A) /= [n+2,n-1])) call abort() + if (any(lcobound (A) /= [n+2,n-1])) call abort() + if (any(ucobound (A) /= [n+5,n-1])) call abort() + end subroutine three_b + + 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 --- /dev/null 2011-03-28 19:44:49.502024685 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_15.f90 2011-04-03 15:49:47.000000000 +0200 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! +! Contributed by John Reid. +! +program ex2 + implicit none + real, allocatable :: z(:)[:] + integer :: image + character(len=80) :: str + + allocate(z(3)[*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:)[image] = z + end do + end if + sync all + + str = repeat('X', len(str)) + write(str,*) 'z=',z(:),' on image',this_image() + if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") & + call abort () + + str = repeat('X', len(str)) + write(str,*) 'z=',z,' on image',this_image() + if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") & + call abort () + + str = repeat('X', len(str)) + write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image() + if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") & + call abort () + + call ex2a() + call ex5() +end + +subroutine ex2a() + implicit none + real, allocatable :: z(:,:)[:,:] + integer :: image + character(len=100) :: str + + allocate(z(2,2)[1,*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:,:)[1,image] = z + end do + end if + sync all + + str = repeat('X', len(str)) + write(str,*) 'z=',z(:,:),' on image',this_image() + if (str /= " z= 1.2000000 1.2000000 1.2000000 1.2000000 on image 1") & + call abort () + + str = repeat('X', len(str)) + write(str,*) 'z=',z,' on image',this_image() + if (str /= " z= 1.2000000 1.2000000 1.2000000 1.2000000 on image 1") & + call abort () +end subroutine ex2a + +subroutine ex5 + implicit none + integer :: me + real, save :: w(4)[*] + character(len=100) :: str + + me = this_image() + w = me + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w + if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") & + call abort () + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w(1:4) + if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") & + call abort () + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1] + if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") & + call abort () + + sync all + call ex5_sub(me,w) +end subroutine ex5 + +subroutine ex5_sub(n,w) + implicit none + integer :: n + real :: w(n) + character(len=50) :: str + + str = repeat('X', len(str)) + write(str,*) 'In sub on image',this_image(), 'w= ',w + if (str /= " In sub on image 1 w= 1.0000000") & + call abort () +end subroutine ex5_sub ^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch 2011-04-03 15:03 ` Tobias Burnus @ 2011-04-04 9:44 ` Daniel Kraft 2011-04-04 18:35 ` Tobias Burnus 0 siblings, 1 reply; 4+ messages in thread From: Daniel Kraft @ 2011-04-04 9:44 UTC (permalink / raw) To: gcc-patches; +Cc: fortran Hi Tobias, On 04/03/11 17:03, Tobias Burnus wrote: > For the support, the scalarizer had to be modified and the cobounds had > to be saved in the descriptor (and in TYPE_LANG_SPECIFIC(node)). I'm all but an expert on this area (maybe you could ask Mikael for his opinion on the scalarizer changes), but isn't this TYPE_LANG_SPECIFIC stuff only for compile-time known things? > Build and regtested on x86-64-linux. > OK for the trunk? Ok, but please consider the (minor) comments below. @@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return true; + { + int n; + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return true; + } It seems to me there's some tab-vs-space issue here (for the int and for lines). @@ -3152,6 +3173,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: loop->dimen = ss->data.info.dimen; + loop->codimen = 0; + break; + + 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; That doesn't change anything, but I'd rather have a "break" for the new cases (even though there was none before and fall-through just has the same effect). It seems clearer to me as you don't do anything "special" via fall-through. @@ -3739,7 +3780,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) info = &ss->data.info; dim = info->dim[n]; - if (loopspec[n] != NULL) + if (loopspec[n] != NULL /*|| n >= loop->dimen*/) { specinfo = &loopspec[n]->data.info; spec_dim = specinfo->dim[n]; Could you clarify (via a comment or the like) why you add this commented-out code? Or rather remove it and add later seems also like a good possibility to me. @@ -7386,8 +7484,9 @@ 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++; break; Nit: Please add appropriate spacing around the "+" in the "long line". (As it is in the hunk above.) Yours, Daniel ^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch 2011-04-04 9:44 ` Daniel Kraft @ 2011-04-04 18:35 ` Tobias Burnus 0 siblings, 0 replies; 4+ messages in thread From: Tobias Burnus @ 2011-04-04 18:35 UTC (permalink / raw) To: Daniel Kraft; +Cc: gcc patches, gfortran Daniel Kraft wrote: > On 04/03/11 17:03, Tobias Burnus wrote: >> For the support, the scalarizer had to be modified and the cobounds had >> to be saved in the descriptor (and in TYPE_LANG_SPECIFIC(node)). > > I'm all but an expert on this area (maybe you could ask Mikael for his > opinion on the scalarizer changes), I am happy for any additional comment. > but isn't this TYPE_LANG_SPECIFIC stuff only for compile-time known > things? Yes and no. gfortran only uses array descriptors for deferred-shape and assumed-shape arrays ("A(:)") - for all other arrays (e.g. "A(4)", "A(n)") the bounds only live as "tree" in the the array's TYPE_LANG_SPECIFIC(node). If one needs them, e.g. to create an an array descriptor on in the scalarizer, one uses the such stored "tree" for assignment etc. Hence, the bounds are stored there - and live there only at compile time - but the they are used to materialize if needed. > @@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e) > It seems to me there's some tab-vs-space issue here (for the int and > for lines). Indeed, a "tab" was missing in the "int" line. > @@ -3152,6 +3173,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) > That doesn't change anything, but I'd rather have a "break" for the > new cases (even though there was none before and fall-through just has > the same effect). It seems clearer to me as you don't do anything > "special" via fall-through. Done. > @@ -3739,7 +3780,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus > * where) > + if (loopspec[n] != NULL /*|| n >= loop->dimen*/) > > Or rather remove it and add later seems also like a good possibility > to me. Removed outcommented code. > @@ -7386,8 +7484,9 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * > expr) > + > newss->data.info.dim[newss->data.info.dimen+newss->data.info.codimen] > = n; > > Nit: Please add appropriate spacing around the "+" in the "long line". > (As it is in the hunk above.) Done - or actually: I also added a line break as the line was too long. Committed as Rev. 171949. Thanks for the review! Tobias ^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2011-04-04 18:35 UTC | newest] Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2011-03-31 22:20 [Patch, Fortran] PR18918 - UCOBOUND coarray draft patch Tobias Burnus 2011-04-03 15:03 ` Tobias Burnus 2011-04-04 9:44 ` Daniel Kraft 2011-04-04 18:35 ` Tobias Burnus
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).