From a3935ffcb75885f82b3034c8b45bc54b14b49cff Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Mon, 4 Apr 2011 20:35:13 +0200 Subject: [PATCH] re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 2011-04-04 Tobias Burnus Mikael Morin 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-04 Tobias Burnus PR fortran/18918 * 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. Co-Authored-By: Mikael Morin From-SVN: r171949 --- gcc/fortran/ChangeLog | 36 ++++ 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 | 206 +++++++++++++++++------ 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/ChangeLog | 7 + gcc/testsuite/gfortran.dg/coarray_10.f90 | 6 + gcc/testsuite/gfortran.dg/coarray_13.f90 | 138 ++++++++++++++- gcc/testsuite/gfortran.dg/coarray_15.f90 | 112 ++++++++++++ 16 files changed, 705 insertions(+), 136 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_15.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 16d824ae6eb..f9513dbf650 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,39 @@ +2011-04-04 Tobias Burnus + Mikael Morin + + 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 Kai Tietz PR middle-end/48422 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index adb4b95368d..bb56122137e 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 58b6036094a..287a2a24e3c 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 eec737c10c0..495923a2466 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 b0b74c14b9f..00fd24ac247 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 1fef22b2469..01999e5f250 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 69edad8e0b5..2a994454b05 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 ac08c42c944..0046d0ac103 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,15 @@ 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; + break; default: break; @@ -3164,7 +3194,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 +3209,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 +3225,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 +3738,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 +3767,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; @@ -3807,7 +3849,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 +3876,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 +3920,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 +4706,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 +5688,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 +5752,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 +5775,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 +5808,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 +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 = 0; 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->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 +7445,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 +7471,10 @@ 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 +7486,10 @@ 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 a0bbe537795..cc6fced4c0c 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 fa3e4c2c060..a3c2ecda0c6 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. */ @@ -1116,6 +1117,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) { @@ -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 8ecceea8ffd..7e12f08beaf 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 19e86bb951a..543ad525b1a 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/ChangeLog b/gcc/testsuite/ChangeLog index 1fa2c642996..3204df3a820 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2011-04-04 Tobias Burnus + + PR fortran/18918 + * 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. + 2011-04-04 Rainer Orth * gfortran.dg/bessel_6.f90: Use dg-add-options ieee. diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 6ee425d7bf9..d32e25478c7 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 bbd1ad49173..1c79a079130 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 diff --git a/gcc/testsuite/gfortran.dg/coarray_15.f90 b/gcc/testsuite/gfortran.dg/coarray_15.f90 new file mode 100644 index 00000000000..91584e26df8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_15.f90 @@ -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 -- 2.30.2