OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

Browse Source 
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-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.


Co-Authored-By: Mikael Morin <mikael.morin@sfr.fr>

From-SVN: r171949
This commit is contained in:
Tobias Burnus 2011-04-04 20:35:13 +02:00 committed by Tobias Burnus
parent b77f9eab26
commit a3935ffcb7
16 changed files with 704 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gcc/fortran/ChangeLog
View File

@ -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

10
gcc/fortran/check.c
View File

@ -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;

7
gcc/fortran/expr.c
View File

@ -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;
}

2
gcc/fortran/gfortran.h
View File

@ -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

26
gcc/fortran/interface.c
View File

@ -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)

41
gcc/fortran/resolve.c
View File

@ -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)

43
gcc/fortran/simplify.c
View File

@ -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);
}

204
gcc/fortran/trans-array.c
View File

@ -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);
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;
/* 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;
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);
}
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);
/* 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:

16
gcc/fortran/trans-decl.c
View File

@ -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,

150
gcc/fortran/trans-intrinsic.c
View File

@ -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:

32
gcc/fortran/trans-types.c
View File

@ -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;

9
gcc/fortran/trans.h
View File

@ -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)

7
gcc/testsuite/ChangeLog
View File

@ -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.

6
gcc/testsuite/gfortran.dg/coarray_10.f90
View File

@ -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

138
gcc/testsuite/gfortran.dg/coarray_13.f90
View File

@ -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

112
gcc/testsuite/gfortran.dg/coarray_15.f90 Normal file
View File

@ -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