aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog36
-rw-r--r--gcc/fortran/check.c10
-rw-r--r--gcc/fortran/expr.c7
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/interface.c26
-rw-r--r--gcc/fortran/resolve.c41
-rw-r--r--gcc/fortran/simplify.c43
-rw-r--r--gcc/fortran/trans-array.c206
-rw-r--r--gcc/fortran/trans-decl.c16
-rw-r--r--gcc/fortran/trans-intrinsic.c150
-rw-r--r--gcc/fortran/trans-types.c32
-rw-r--r--gcc/fortran/trans.h9
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_10.f906
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_13.f90138
-rw-r--r--gcc/testsuite/gfortran.dg/coarray_15.f90112
16 files changed, 705 insertions, 136 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 16d824a..f9513db 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,39 @@
+2011-04-04 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 Kai Tietz <ktietz@redhat.com>
PR middle-end/48422
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index adb4b953..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..287a2a2 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..0046d0ac 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 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/ChangeLog b/gcc/testsuite/ChangeLog
index 1fa2c64..3204df3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2011-04-04 Tobias Burnus <burnus@net-b.de>
+
+ 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 <ro@CeBiTec.Uni-Bielefeld.DE>
* 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 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
diff --git a/gcc/testsuite/gfortran.dg/coarray_15.f90 b/gcc/testsuite/gfortran.dg/coarray_15.f90
new file mode 100644
index 0000000..91584e2
--- /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
generated by cgit v1.1 at 2024-10-01 18:42:30 +0000