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> 2011-04-03 Kai Tietz <ktietz@redhat.com>
PR middle-end/48422 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) if (ref->type == REF_COMPONENT)
coarray = ref->u.c.component->attr.codimension; coarray = ref->u.c.component->attr.codimension;
else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0)
|| ref->u.ar.codimen != 0)
coarray = false; 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; 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) for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 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; 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 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 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; gfc_ref *last = NULL;
if (actual->expr_type != EXPR_VARIABLE if (actual->expr_type != EXPR_VARIABLE
|| (actual->ref == NULL || !gfc_expr_attr (actual).codimension)
&& !actual->symtree->n.sym->attr.codimension))
{ {
if (where) if (where)
gfc_error ("Actual argument to '%s' at %L must be a coarray", 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; 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) 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 if (ref->type == REF_ARRAY && ref->u.ar.as->corank
&& ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0) && 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; 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. */ /* F2008, 12.5.2.6. */
if (formal->attr.allocatable && if (formal->attr.allocatable &&
((last && last->u.c.component->as->corank != formal->as->corank) ((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]) switch (ar->dimen_type[i])
{ {
case DIMEN_VECTOR: case DIMEN_VECTOR:
case DIMEN_THIS_IMAGE:
break; break;
case DIMEN_STAR: case DIMEN_STAR:
@ -4324,7 +4325,8 @@ compare_spec_to_ref (gfc_array_ref *ar)
if (ar->codimen != 0) if (ar->codimen != 0)
for (i = as->rank; i < as->rank + as->corank; i++) 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", gfc_error ("Coindex of codimension %d must be a scalar at %L",
i + 1 - as->rank, &ar->where); i + 1 - as->rank, &ar->where);
@ -4334,6 +4336,14 @@ compare_spec_to_ref (gfc_array_ref *ar)
return FAILURE; 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; return SUCCESS;
} }
@ -6848,12 +6858,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
ar = &ref2->u.ar; ar = &ref2->u.ar;
if (codimension && ar->codimen == 0) if (codimension)
{ for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
gfc_error ("Coarray specification required in ALLOCATE statement " if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
"at %L", &e->where); {
goto failure; gfc_error ("Coarray specification required in ALLOCATE statement "
} "at %L", &e->where);
goto failure;
}
for (i = 0; i < ar->dimen; i++) 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_UNKNOWN:
case DIMEN_VECTOR: case DIMEN_VECTOR:
case DIMEN_STAR: case DIMEN_STAR:
case DIMEN_THIS_IMAGE:
gfc_error ("Bad array specification in ALLOCATE statement at %L", gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where); &e->where);
goto failure; goto failure;
@ -12501,18 +12514,18 @@ check_data_variable (gfc_data_variable *var, locus *where)
has_pointer = sym->attr.pointer; 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) for (ref = e->ref; ref; ref = ref->next)
{ {
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1; 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 if (has_pointer
&& ref->type == REF_ARRAY && ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL) && 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_expr *
gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{ {
gfc_expr *e; return simplify_cobound (array, dim, kind, 0);
/* 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;
} }
gfc_expr * gfc_expr *
@ -6338,7 +6329,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
as = ref->u.ar.as; as = ref->u.ar.as;
if (as->type == AS_DEFERRED) if (as->type == AS_DEFERRED)
goto not_implemented; /* return NULL;*/ return NULL;
if (dim == NULL) if (dim == NULL)
{ {
@ -6357,8 +6348,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
for (j = 0; j < d; j++) for (j = 0; j < d; j++)
gfc_free_expr (bounds[j]); gfc_free_expr (bounds[j]);
if (bounds[d] == NULL)
goto not_implemented;
return bounds[d]; return bounds[d];
} }
} }
@ -6383,10 +6373,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
} }
else else
{ {
gfc_expr *e;
/* A DIM argument is specified. */ /* A DIM argument is specified. */
if (dim->expr_type != EXPR_CONSTANT) if (dim->expr_type != EXPR_CONSTANT)
goto not_implemented; /*return NULL;*/ return NULL;
d = mpz_get_si (dim->value.integer); 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 &gfc_bad_expr;
} }
/*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); true);
if (e != NULL)
return e;
else
goto not_implemented;
} }
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_expr *
gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{ {
gfc_expr *e; return simplify_cobound (array, dim, kind, 1);
/* 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;
} }

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; tree tmp;
if (as && as->type == AS_EXPLICIT) 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]; dim = se->ss->data.info.dim[n];
gcc_assert (dim < as->rank); 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); gfc_add_block_to_block (&se->post, &tmpse.post);
lower = fold_convert (gfc_array_index_type, tmpse.expr); lower = fold_convert (gfc_array_index_type, tmpse.expr);
/* ...and the upper bound. */ if (se->loop->codimen == 0
gfc_init_se (&tmpse, NULL); || n < se->loop->dimen + se->loop->codimen - 1)
gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); {
gfc_add_block_to_block (&se->pre, &tmpse.pre); /* ...and the upper bound. */
gfc_add_block_to_block (&se->post, &tmpse.post); gfc_init_se (&tmpse, NULL);
upper = fold_convert (gfc_array_index_type, tmpse.expr); 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. */ /* Set the upper bound of the loop to UPPER - LOWER. */
tmp = fold_build2_loc (input_location, MINUS_EXPR, tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, upper, lower); gfc_array_index_type, upper, lower);
tmp = gfc_evaluate_now (tmp, &se->pre); tmp = gfc_evaluate_now (tmp, &se->pre);
se->loop->to[n] = tmp; se->loop->to[n] = tmp;
}
} }
} }
} }
@ -885,6 +889,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
size, tmp); size, tmp);
size = gfc_evaluate_now (size, pre); 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. */ /* 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->data = gfc_build_addr_expr (NULL_TREE, tmp);
info->offset = gfc_index_zero_node; 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->delta[i] = gfc_index_zero_node;
info->start[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 n;
int dim; int dim;
for (n = 0; n < loop->dimen; n++) for (n = 0; n < loop->dimen + loop->codimen; n++)
{ {
dim = info->dim[n]; dim = info->dim[n];
if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR 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); gcc_assert (ar->type != AR_ELEMENT);
switch (ar->dimen_type[dim]) switch (ar->dimen_type[dim])
{ {
case DIMEN_THIS_IMAGE:
gcc_unreachable ();
break;
case DIMEN_ELEMENT: case DIMEN_ELEMENT:
/* Elemental dimension. */ /* Elemental dimension. */
gcc_assert (info->subscript[dim] gcc_assert (info->subscript[dim]
@ -2813,7 +2827,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
gcc_assert (!loop->array_parameter); 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]; n = loop->order[dim];
@ -2967,7 +2981,7 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
pblock = body; pblock = body;
/* Generate the loops. */ /* Generate the loops. */
for (dim = 0; dim < loop->dimen; dim++) for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
{ {
n = loop->order[dim]; n = loop->order[dim];
gfc_trans_scalarized_loop_end (loop, n, pblock); 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. */ /* Calculate the lower bound of an array section. */
static void 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 *start;
gfc_expr *end; gfc_expr *end;
gfc_expr *stride; gfc_expr *stride = NULL;
tree desc; tree desc;
gfc_se se; gfc_se se;
gfc_ss_info *info; 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. */ /* We use a zero-based index to access the vector. */
info->start[dim] = gfc_index_zero_node; info->start[dim] = gfc_index_zero_node;
info->stride[dim] = gfc_index_one_node;
info->end[dim] = NULL; info->end[dim] = NULL;
if (!coarray)
info->stride[dim] = gfc_index_one_node;
return; return;
} }
@ -3069,7 +3085,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
desc = info->descriptor; desc = info->descriptor;
start = info->ref->u.ar.start[dim]; start = info->ref->u.ar.start[dim];
end = info->ref->u.ar.end[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 /* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */ 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 /* Similarly calculate the end. Although this is not used in the
scalarizer, it is needed when checking bounds and where the end scalarizer, it is needed when checking bounds and where the end
is an expression with side-effects. */ is an expression with side-effects. */
if (end) if (!coarray_last)
{ {
/* Specified section start. */ if (end)
gfc_init_se (&se, NULL); {
gfc_conv_expr_type (&se, end, gfc_array_index_type); /* Specified section start. */
gfc_add_block_to_block (&loop->pre, &se.pre); gfc_init_se (&se, NULL);
info->end[dim] = se.expr; 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. */ /* Calculate the stride. */
if (stride == NULL) if (!coarray && stride == NULL)
info->stride[dim] = gfc_index_one_node; info->stride[dim] = gfc_index_one_node;
else else if (!coarray)
{ {
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type); 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_FUNCTION:
case GFC_SS_COMPONENT: case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen; loop->dimen = ss->data.info.dimen;
loop->codimen = ss->data.info.codimen;
break; break;
/* As usual, lbound and ubound are exceptions!. */ /* 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_LBOUND:
case GFC_ISYM_UBOUND: case GFC_ISYM_UBOUND:
loop->dimen = ss->data.info.dimen; 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: default:
break; break;
@ -3164,7 +3194,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
/* We should have determined the rank of the expression by now. If /* We should have determined the rank of the expression by now. If
not, that's bad news. */ 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. */ /* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_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); gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
for (n = 0; n < ss->data.info.dimen; n++) 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; break;
case GFC_SS_INTRINSIC: case GFC_SS_INTRINSIC:
@ -3188,7 +3225,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
/* Fall through to supply start and stride. */ /* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND: case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND: case GFC_ISYM_UBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
break; break;
default: default:
continue; continue;
} }
@ -3697,6 +3738,7 @@ temporary:
loop->temp_ss->data.temp.type = base_type; loop->temp_ss->data.temp.type = base_type;
loop->temp_ss->string_length = dest->string_length; loop->temp_ss->string_length = dest->string_length;
loop->temp_ss->data.temp.dimen = loop->dimen; loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->data.temp.codimen = loop->codimen;
loop->temp_ss->next = gfc_ss_terminator; loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss); 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_t i;
mpz_init (i); mpz_init (i);
for (n = 0; n < loop->dimen; n++) for (n = 0; n < loop->dimen + loop->codimen; n++)
{ {
loopspec[n] = NULL; loopspec[n] = NULL;
dynamic[n] = false; dynamic[n] = false;
@ -3807,7 +3849,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
known lower bound known lower bound
known upper 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; loopspec[n] = ss;
else if (integer_onep (info->stride[dim]) else if (integer_onep (info->stride[dim])
&& !integer_onep (specinfo->stride[spec_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. */ /* Set the extents of this range. */
cshape = loopspec[n]->shape; 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])) && INTEGER_CST_P (info->stride[dim]))
{ {
loop->from[n] = info->start[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. */ /* 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; info->delta[dim] = gfc_index_zero_node;
else else if (n < loop->dimen)
{ {
/* Set the delta for this section. */ /* Set the delta for this section. */
info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); 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; 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); gfc_trans_vla_type_sizes (sym, pblock);
*poffset = offset; *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; se->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen; 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); 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. limits will be the limits of the section.
A function may decide to repack the array to speed up access, but A function may decide to repack the array to speed up access, but
we're not bothered about that here. */ we're not bothered about that here. */
int dim, ndim; int dim, ndim, codim;
tree parm; tree parm;
tree parmtype; tree parmtype;
tree stride; tree stride;
@ -5712,8 +5775,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{ {
/* Otherwise make a new one. */ /* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc)); parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 0, loop.codimen, loop.from,
loop.to, 0,
GFC_ARRAY_UNKNOWN, false); GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm"); 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; base = NULL_TREE;
ndim = info->ref ? info->ref->u.ar.dimen : info->dimen; ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
codim = info->codimen;
for (n = 0; n < ndim; n++) for (n = 0; n < ndim; n++)
{ {
stride = gfc_conv_array_stride (desc, 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); 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) if (se->data_not_needed)
gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_conv_descriptor_data_set (&loop.pre, parm,
gfc_index_zero_node); gfc_index_zero_node);
@ -7311,7 +7396,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
switch (ar->type) switch (ar->type)
{ {
case AR_ELEMENT: case AR_ELEMENT:
for (n = 0; n < ar->dimen; n++) for (n = 0; n < ar->dimen + ar->codimen; n++)
{ {
newss = gfc_get_ss (); newss = gfc_get_ss ();
newss->type = GFC_SS_SCALAR; newss->type = GFC_SS_SCALAR;
@ -7327,11 +7412,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
newss->expr = expr; newss->expr = expr;
newss->next = ss; newss->next = ss;
newss->data.info.dimen = ar->as->rank; newss->data.info.dimen = ar->as->rank;
newss->data.info.codimen = 0;
newss->data.info.ref = ref; newss->data.info.ref = ref;
/* Make sure array is the same as array(:,:), this way /* Make sure array is the same as array(:,:), this way
we don't need to special case all the time. */ we don't need to special case all the time. */
ar->dimen = ar->as->rank; ar->dimen = ar->as->rank;
ar->codimen = 0;
for (n = 0; n < ar->dimen; n++) for (n = 0; n < ar->dimen; n++)
{ {
newss->data.info.dim[n] = 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->end[n] == NULL);
gcc_assert (ar->stride[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; ss = newss;
break; break;
@ -7350,15 +7445,18 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
newss->expr = expr; newss->expr = expr;
newss->next = ss; newss->next = ss;
newss->data.info.dimen = 0; newss->data.info.dimen = 0;
newss->data.info.codimen = 0;
newss->data.info.ref = ref; newss->data.info.ref = ref;
/* We add SS chains for all the subscripts in the section. */ /* 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; gfc_ss *indexss;
switch (ar->dimen_type[n]) switch (ar->dimen_type[n])
{ {
case DIMEN_THIS_IMAGE:
continue;
case DIMEN_ELEMENT: case DIMEN_ELEMENT:
/* Add SS for elemental (scalar) subscripts. */ /* Add SS for elemental (scalar) subscripts. */
gcc_assert (ar->start[n]); gcc_assert (ar->start[n]);
@ -7373,8 +7471,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
case DIMEN_RANGE: case DIMEN_RANGE:
/* We don't add anything for sections, just remember this /* We don't add anything for sections, just remember this
dimension for later. */ dimension for later. */
newss->data.info.dim[newss->data.info.dimen] = n; newss->data.info.dim[newss->data.info.dimen
newss->data.info.dimen++; + newss->data.info.codimen] = n;
if (n < ar->dimen)
newss->data.info.dimen++;
break; break;
case DIMEN_VECTOR: case DIMEN_VECTOR:
@ -7386,8 +7486,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
indexss->next = gfc_ss_terminator; indexss->next = gfc_ss_terminator;
indexss->loop_chain = gfc_ss_terminator; indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss; newss->data.info.subscript[n] = indexss;
newss->data.info.dim[newss->data.info.dimen] = n; newss->data.info.dim[newss->data.info.dimen
newss->data.info.dimen++; + newss->data.info.codimen] = n;
if (n < ar->dimen)
newss->data.info.dimen++;
break; break;
default: 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; 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) if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{ {
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, 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; se->expr = gfort_gvar_caf_num_images;
} }
/* Evaluate a single upper or lower bound. */ /* Evaluate a single upper or lower bound. */
/* TODO: bound intrinsic generates way too much unnecessary code. */ /* 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 else
{ {
/* use the passed argument. */ /* use the passed argument. */
gcc_assert (arg->next->expr); gcc_assert (arg2->expr);
gfc_init_se (&argse, NULL); 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); gfc_add_block_to_block (&se->pre, &argse.pre);
bound = argse.expr; bound = argse.expr;
/* Convert from one based to zero based. */ /* 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 static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) 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); gfc_conv_intrinsic_bound (se, expr, 0);
break; break;
case GFC_ISYM_LCOBOUND:
conv_intrinsic_cobound (se, expr);
break;
case GFC_ISYM_TRANSPOSE: case GFC_ISYM_TRANSPOSE:
/* The scalarizer has already been set up for reversed dimension access /* The scalarizer has already been set up for reversed dimension access
order ; now we just get the argument value normally. */ 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); gfc_conv_intrinsic_bound (se, expr, 1);
break; break;
case GFC_ISYM_UCOBOUND:
conv_intrinsic_cobound (se, expr);
break;
case GFC_ISYM_XOR: case GFC_ISYM_XOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
break; break;
@ -6126,7 +6257,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break; break;
case GFC_ISYM_THIS_IMAGE: 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; break;
case GFC_ISYM_NUM_IMAGES: 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_UBOUND:
case GFC_ISYM_LBOUND: case GFC_ISYM_LBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_THIS_IMAGE:
break; break;
default: 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 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
inside the scalarization loop. */ are expanded into code inside the scalarization loop. */
static gfc_ss * static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) 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) switch (isym->id)
{ {
case GFC_ISYM_LBOUND: case GFC_ISYM_LBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UBOUND: case GFC_ISYM_UBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
return gfc_walk_intrinsic_bound (ss, expr); return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER: 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]); 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) if (as->type == AS_ASSUMED_SHAPE)
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE; : 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) if (packed == PACKED_NO || packed == PACKED_PARTIAL)
known_stride = 0; 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) 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_SIZE (type) = NULL_TREE;
GFC_TYPE_ARRAY_RANK (type) = as->rank; GFC_TYPE_ARRAY_RANK (type) = as->rank;
GFC_TYPE_ARRAY_CORANK (type) = as->corank;
GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE); 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)); = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
GFC_TYPE_ARRAY_RANK (fat_type) = dimen; 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_DTYPE (fat_type) = NULL_TREE;
GFC_TYPE_ARRAY_AKIND (fat_type) = akind; 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 typedef struct gfc_ss_info
{ {
int dimen; int dimen, codimen;
/* The ref that holds information on this section. */ /* The ref that holds information on this section. */
gfc_ref *ref; gfc_ref *ref;
/* The descriptor of this array. */ /* 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 /* The rank of the temporary. May be less than the rank of the
assigned expression. */ assigned expression. */
int dimen; int dimen, codimen;
tree type; tree type;
} }
temp; temp;
@ -231,7 +231,7 @@ typedef struct gfc_loopinfo
stmtblock_t pre; stmtblock_t pre;
stmtblock_t post; stmtblock_t post;
int dimen; int dimen, codimen;
/* All the SS involved with this loop. */ /* All the SS involved with this loop. */
gfc_ss *ss; gfc_ss *ss;
@ -713,7 +713,7 @@ enum gfc_array_kind
variable-sized in some other frontends. Due to gengtype deficiency the GTY variable-sized in some other frontends. Due to gengtype deficiency the GTY
options of such types have to agree across all frontends. */ options of such types have to agree across all frontends. */
struct GTY((variable_size)) lang_type { struct GTY((variable_size)) lang_type {
int rank; int rank, corank;
enum gfc_array_kind akind; enum gfc_array_kind akind;
tree lbound[GFC_MAX_DIMENSIONS]; tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[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) \ #define GFC_TYPE_ARRAY_STRIDE(node, dim) \
(TYPE_LANG_SPECIFIC(node)->stride[dim]) (TYPE_LANG_SPECIFIC(node)->stride[dim])
#define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank) #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_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
#define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset) #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
#define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind) #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> 2011-04-04 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* gfortran.dg/bessel_6.f90: Use dg-add-options ieee. * 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 ! { dg-error "Too few codimensions" }
A(1)[1,1:1] = 1 ! { dg-error "Too few codimensions" } A(1)[1,1:1] = 1 ! { dg-error "Too few codimensions" }
end subroutine rank_mismatch 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-do run }
! { dg-options "-fcoarray=single" } ! { dg-options "-fcoarray=single -fcheck=bounds" }
! !
! Coarray support -- allocatable array coarrays ! Coarray support -- allocatable array coarrays
! -- intrinsic procedures
! PR fortran/18918 ! PR fortran/18918
! PR fortran/43931 ! PR fortran/43931
! !
program test program test
implicit none implicit none
integer,allocatable :: B(:)[:]
call one() 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 contains
subroutine one() subroutine one()
integer, allocatable :: a(:)[:,:,:] integer, allocatable :: a(:)[:,:,:]
allocate(a(1)[-4:9,8,4:*]) 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 end subroutine one
subroutine four(C)
integer, allocatable :: C(:)[:] subroutine two()
end subroutine four 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 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