re PR fortran/29785 (Fortran 2003: POINTER Rank Remapping)

2010-08-19  Daniel Kraft  <d@domob.eu>

	PR fortran/29785
	PR fortran/45016
	* trans.h (struct gfc_se): New flag `byref_noassign'.
	* trans-array.h (gfc_conv_shift_descriptor_lbound): New method.
	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
	* expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping
	and check for compile-time errors with those.
	* trans-decl.c (trans_associate_var): Use new routine
	`gfc_conv_shift_descriptor_lbound' instead of doing it manually.
	* trans-array.c (gfc_conv_shift_descriptor_lbound): New method.
	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
	(gfc_array_init_size): Use new `gfc_conv_array_extent_dim'.
	(gfc_conv_expr_descriptor): Handle new flag `byref_noassign'.
	* trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and
	rank remapping for assignment.

2010-08-19  Daniel Kraft  <d@domob.eu>

	PR fortran/29785
	PR fortran/45016
	* gfortran.dg/pointer_assign_5.f90: Remove 'not implemented' error.
	* gfortran.dg/pointer_remapping_1.f90: New test.
	* gfortran.dg/pointer_remapping_2.f03: New test.
	* gfortran.dg/pointer_remapping_3.f08: New test.
	* gfortran.dg/pointer_remapping_4.f03: New test.
	* gfortran.dg/pointer_remapping_5.f08: New test.
	* gfortran.dg/pointer_remapping_6.f08: New test.

From-SVN: r163377
This commit is contained in:
Daniel Kraft 2010-08-19 18:02:30 +02:00 committed by Daniel Kraft
parent f1b62c9f96
commit 99d821c01c
15 changed files with 608 additions and 108 deletions

View File

@ -1,3 +1,21 @@
2010-08-19 Daniel Kraft <d@domob.eu>
PR fortran/29785
PR fortran/45016
* trans.h (struct gfc_se): New flag `byref_noassign'.
* trans-array.h (gfc_conv_shift_descriptor_lbound): New method.
(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
* expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping
and check for compile-time errors with those.
* trans-decl.c (trans_associate_var): Use new routine
`gfc_conv_shift_descriptor_lbound' instead of doing it manually.
* trans-array.c (gfc_conv_shift_descriptor_lbound): New method.
(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
(gfc_array_init_size): Use new `gfc_conv_array_extent_dim'.
(gfc_conv_expr_descriptor): Handle new flag `byref_noassign'.
* trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and
rank remapping for assignment.
2010-08-19 Tobias Burnus <burnus@net-b.de>
* intrinsic.texi (Bessel_jn, Bessel_yn): Fix typo.

View File

@ -3232,7 +3232,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
gfc_ref *ref;
int is_pure;
bool is_pure, rank_remap;
int pointer, check_intent_in, proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
@ -3260,6 +3260,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
pointer = lvalue->symtree->n.sym->attr.pointer;
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
rank_remap = false;
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (pointer)
@ -3273,6 +3274,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
int dim;
if (ref->u.ar.type == AR_FULL)
break;
@ -3285,16 +3288,41 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
"specification for '%s' in pointer assignment "
"at %L", lvalue->symtree->n.sym->name,
"at %L", lvalue->symtree->n.sym->name,
&lvalue->where) == FAILURE)
return FAILURE;
return FAILURE;
gfc_error ("Pointer bounds remapping at %L is not yet implemented "
"in gfortran", &lvalue->where);
/* TODO: See PR 29785. Add checks that all lbounds are specified and
either never or always the upper-bound; strides shall not be
present. */
return FAILURE;
/* When bounds are given, all lbounds are necessary and either all
or none of the upper bounds; no strides are allowed. If the
upper bounds are present, we may do rank remapping. */
for (dim = 0; dim < ref->u.ar.dimen; ++dim)
{
if (!ref->u.ar.start[dim])
{
gfc_error ("Lower bound has to be present at %L",
&lvalue->where);
return FAILURE;
}
if (ref->u.ar.stride[dim])
{
gfc_error ("Stride must not be present at %L",
&lvalue->where);
return FAILURE;
}
if (dim == 0)
rank_remap = (ref->u.ar.end[dim] != NULL);
else
{
if ((rank_remap && !ref->u.ar.end[dim])
|| (!rank_remap && ref->u.ar.end[dim]))
{
gfc_error ("Either all or none of the upper bounds"
" must be specified at %L", &lvalue->where);
return FAILURE;
}
}
}
}
}
@ -3456,13 +3484,47 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE;
}
if (lvalue->rank != rvalue->rank)
if (lvalue->rank != rvalue->rank && !rank_remap)
{
gfc_error ("Different ranks in pointer assignment at %L",
&lvalue->where);
gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
return FAILURE;
}
/* Check rank remapping. */
if (rank_remap)
{
mpz_t lsize, rsize;
/* If this can be determined, check that the target must be at least as
large as the pointer assigned to it is. */
if (gfc_array_size (lvalue, &lsize) == SUCCESS
&& gfc_array_size (rvalue, &rsize) == SUCCESS
&& mpz_cmp (rsize, lsize) < 0)
{
gfc_error ("Rank remapping target is smaller than size of the"
" pointer (%ld < %ld) at %L",
mpz_get_si (rsize), mpz_get_si (lsize),
&lvalue->where);
return FAILURE;
}
/* The target must be either rank one or it must be simply contiguous
and F2008 must be allowed. */
if (rvalue->rank != 1)
{
if (!gfc_is_simply_contiguous (rvalue, true))
{
gfc_error ("Rank remapping target must be rank 1 or"
" simply contiguous at %L", &rvalue->where);
return FAILURE;
}
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
" target is not rank 1 at %L", &rvalue->where)
== FAILURE)
return FAILURE;
}
}
/* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
if (rvalue->expr_type == EXPR_NULL)
return SUCCESS;

View File

@ -382,6 +382,39 @@ gfc_build_null_descriptor (tree type)
}
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
void
gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
int dim, tree new_lbound)
{
tree offs, ubound, lbound, stride;
tree diff, offs_diff;
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
offs = gfc_conv_descriptor_offset_get (desc);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
/* Get difference (new - old) by which to shift stuff. */
diff = fold_build2 (MINUS_EXPR, gfc_array_index_type, new_lbound, lbound);
/* Shift ubound and offset accordingly. This has to be done before
updating the lbound, as they depend on the lbound expression! */
ubound = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, diff);
gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
offs_diff = fold_build2 (MULT_EXPR, gfc_array_index_type, diff, stride);
offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, offs_diff);
gfc_conv_descriptor_offset_set (block, desc, offs);
/* Finally set lbound to value we want. */
gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
}
/* Cleanup those #defines. */
#undef DATA_FIELD
@ -3784,6 +3817,62 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
}
/* Calculate the size of a given array dimension from the bounds. This
is simply (ubound - lbound + 1) if this expression is positive
or 0 if it is negative (pick either one if it is zero). Optionally
(if or_expr is present) OR the (expression != 0) condition to it. */
tree
gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
{
tree res;
tree cond;
/* Calculate (ubound - lbound + 1). */
res = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
res = fold_build2 (PLUS_EXPR, gfc_array_index_type, res, gfc_index_one_node);
/* Check whether the size for this dimension is negative. */
cond = fold_build2 (LE_EXPR, boolean_type_node, res, gfc_index_zero_node);
res = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
gfc_index_zero_node, res);
/* Build OR expression. */
if (or_expr)
*or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, *or_expr, cond);
return res;
}
/* For an array descriptor, get the total number of elements. This is just
the product of the extents along all dimensions. */
tree
gfc_conv_descriptor_size (tree desc, int rank)
{
tree res;
int dim;
res = gfc_index_one_node;
for (dim = 0; dim < rank; ++dim)
{
tree lbound;
tree ubound;
tree extent;
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
res = fold_build2 (MULT_EXPR, gfc_array_index_type, res, extent);
}
return res;
}
/* Fills in an array descriptor, and returns the size of the array. The size
will be a simple_val, ie a variable or a constant. Also calculates the
offset of the base. Returns the size of the array.
@ -3792,13 +3881,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
offset = 0;
for (n = 0; n < rank; n++)
{
a.lbound[n] = specified_lower_bound;
offset = offset + a.lbond[n] * stride;
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
stride = stride * size;
a.lbound[n] = specified_lower_bound;
offset = offset + a.lbond[n] * stride;
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
stride = stride * size;
}
return (stride);
} */
@ -3814,7 +3903,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree size;
tree offset;
tree stride;
tree cond;
tree or_expr;
tree thencase;
tree elsecase;
@ -3834,14 +3922,17 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = NULL_TREE;
or_expr = boolean_false_node;
for (n = 0; n < rank; n++)
{
tree conv_lbound;
tree conv_ubound;
/* We have 3 possibilities for determining the size of the array:
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
ubound = upper[n];
/* Set lower bound. */
@ -3851,52 +3942,41 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
else
{
gcc_assert (lower[n]);
if (ubound)
{
if (ubound)
{
gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
}
else
{
se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
else
{
se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
se.expr);
conv_lbound = se.expr;
/* Work out the offset for this component. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
/* Start the calculation for the size of this dimension. */
size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, se.expr);
/* Set upper bound. */
gfc_init_se (&se, NULL);
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
gfc_conv_descriptor_ubound_set (pblock, descriptor,
gfc_rank_cst[n], se.expr);
conv_ubound = se.expr;
/* Store the stride. */
gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
gfc_conv_descriptor_stride_set (pblock, descriptor,
gfc_rank_cst[n], stride);
/* Calculate the size of this dimension. */
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
/* Check whether the size for this dimension is negative. */
cond = fold_build2 (LE_EXPR, boolean_type_node, size,
gfc_index_zero_node);
if (n == 0)
or_expr = cond;
else
or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
gfc_index_zero_node, size);
/* Calculate size and check whether extent is negative. */
size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
@ -3916,16 +3996,16 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
}
else
{
if (ubound || n == rank + corank - 1)
{
if (ubound || n == rank + corank - 1)
{
gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
}
else
{
se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
else
{
se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
se.expr);
@ -3936,7 +4016,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
gfc_conv_descriptor_ubound_set (pblock, descriptor,
gfc_rank_cst[n], se.expr);
}
}
@ -5064,7 +5145,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
if (full)
{
if (se->direct_byref)
if (se->direct_byref && !se->byref_noassign)
{
/* Copy the descriptor for pointer assignments. */
gfc_add_modify (&se->pre, se->expr, desc);
@ -5269,7 +5350,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
desc = info->descriptor;
gcc_assert (secss && secss != gfc_ss_terminator);
if (se->direct_byref)
if (se->direct_byref && !se->byref_noassign)
{
/* For pointer assignments we fill in the destination. */
parm = se->expr;
@ -5427,7 +5508,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
desc = parm;
}
if (!se->direct_byref)
if (!se->direct_byref || se->byref_noassign)
{
/* Get a pointer to the new descriptor. */
if (se->want_pointer)

View File

@ -139,6 +139,9 @@ void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
@ -149,3 +152,7 @@ tree gfc_build_constant_array_constructor (gfc_expr *, tree);
/* Copy a string from src to dest. */
void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
/* Calculate extent / size of an array. */
tree gfc_conv_array_extent_dim (tree, tree, tree*);
tree gfc_conv_descriptor_size (tree, int);

View File

@ -3133,42 +3133,15 @@ trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
descriptor to the one generated for the temporary. */
if (!sym->assoc->variable)
{
tree offs;
int dim;
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1 all the time.
The offset has to be corrected as well.
Because the ubound shift and offset depends on the lower bounds, we
first calculate those and set the lbound to one last. */
offs = gfc_conv_descriptor_offset_get (desc);
temporary), shift bounds so we get lower bounds of 1. */
for (dim = 0; dim < e->rank; ++dim)
{
tree from, to;
tree stride;
from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, from);
to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
gfc_conv_descriptor_ubound_set (&se.pre, desc,
gfc_rank_cst[dim], to);
}
gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[dim],
gfc_index_one_node);
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
dim, gfc_index_one_node);
}
/* Done, register stuff as init / cleanup code. */

View File

@ -4773,21 +4773,46 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
{
gfc_ref* remap;
bool rank_remap;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
/* Array pointer. */
/* Array pointer. Find the last reference on the LHS and if it is an
array section ref, we're dealing with bounds remapping. In this case,
set it to AR_FULL so that gfc_conv_expr_descriptor does
not see it and process the bounds remapping afterwards explicitely. */
for (remap = expr1->ref; remap; remap = remap->next)
if (!remap->next && remap->type == REF_ARRAY
&& remap->u.ar.type == AR_SECTION)
{
remap->u.ar.type = AR_FULL;
break;
}
rank_remap = (remap && remap->u.ar.end[0]);
gfc_conv_expr_descriptor (&lse, expr1, lss);
strlen_lhs = lse.string_length;
switch (expr2->expr_type)
desc = lse.expr;
if (expr2->expr_type == EXPR_NULL)
{
case EXPR_NULL:
/* Just set the data pointer to null. */
gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
break;
case EXPR_VARIABLE:
/* Assign directly to the pointer's descriptor. */
}
else if (rank_remap)
{
/* If we are rank-remapping, just get the RHS's descriptor and
process this later on. */
gfc_init_se (&rse, NULL);
rse.direct_byref = 1;
rse.byref_noassign = 1;
gfc_conv_expr_descriptor (&rse, expr2, rss);
strlen_rhs = rse.string_length;
}
else if (expr2->expr_type == EXPR_VARIABLE)
{
/* Assign directly to the LHS's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
@ -4806,13 +4831,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
break;
default:
}
else
{
/* Assign to a temporary descriptor and then copy that
temporary to the pointer. */
desc = lse.expr;
tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
lse.expr = tmp;
@ -4820,10 +4843,130 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_conv_expr_descriptor (&lse, expr2, rss);
strlen_rhs = lse.string_length;
gfc_add_modify (&lse.pre, desc, tmp);
break;
}
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
/* If we do bounds remapping, update LHS descriptor accordingly. */
if (remap)
{
int dim;
gcc_assert (remap->u.ar.dimen == expr1->rank);
if (rank_remap)
{
/* Do rank remapping. We already have the RHS's descriptor
converted in rse and now have to build the correct LHS
descriptor for it. */
tree dtype, data;
tree offs, stride;
tree lbound, ubound;
/* Set dtype. */
dtype = gfc_conv_descriptor_dtype (desc);
tmp = gfc_get_dtype (TREE_TYPE (desc));
gfc_add_modify (&block, dtype, tmp);
/* Copy data pointer. */
data = gfc_conv_descriptor_data_get (rse.expr);
gfc_conv_descriptor_data_set (&block, desc, data);
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
offs = gfc_conv_descriptor_offset_get (rse.expr);
for (dim = 0; dim < expr2->rank; ++dim)
{
stride = gfc_conv_descriptor_stride_get (rse.expr,
gfc_rank_cst[dim]);
lbound = gfc_conv_descriptor_lbound_get (rse.expr,
gfc_rank_cst[dim]);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
stride, lbound);
offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
offs, tmp);
}
gfc_conv_descriptor_offset_set (&block, desc, offs);
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
stride = gfc_conv_descriptor_stride_get (rse.expr,
gfc_rank_cst[0]);
for (dim = 0; dim < expr1->rank; ++dim)
{
gfc_se lower_se;
gfc_se upper_se;
gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
gfc_add_block_to_block (&block, &lower_se.pre);
gfc_add_block_to_block (&block, &upper_se.pre);
lbound = fold_convert (gfc_array_index_type, lower_se.expr);
ubound = fold_convert (gfc_array_index_type, upper_se.expr);
lbound = gfc_evaluate_now (lbound, &block);
ubound = gfc_evaluate_now (ubound, &block);
gfc_add_block_to_block (&block, &lower_se.post);
gfc_add_block_to_block (&block, &upper_se.post);
/* Set bounds in descriptor. */
gfc_conv_descriptor_lbound_set (&block, desc,
gfc_rank_cst[dim], lbound);
gfc_conv_descriptor_ubound_set (&block, desc,
gfc_rank_cst[dim], ubound);
/* Set stride. */
stride = gfc_evaluate_now (stride, &block);
gfc_conv_descriptor_stride_set (&block, desc,
gfc_rank_cst[dim], stride);
/* Update offset. */
offs = gfc_conv_descriptor_offset_get (desc);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
lbound, stride);
offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
offs, tmp);
offs = gfc_evaluate_now (offs, &block);
gfc_conv_descriptor_offset_set (&block, desc, offs);
/* Update stride. */
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
stride, tmp);
}
}
else
{
/* Bounds remapping. Just shift the lower bounds. */
gcc_assert (expr1->rank == expr2->rank);
for (dim = 0; dim < remap->u.ar.dimen; ++dim)
{
gfc_se lbound_se;
gcc_assert (remap->u.ar.start[dim]);
gcc_assert (!remap->u.ar.end[dim]);
gfc_init_se (&lbound_se, NULL);
gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
gfc_add_block_to_block (&block, &lbound_se.pre);
gfc_conv_shift_descriptor_lbound (&block, desc,
dim, lbound_se.expr);
gfc_add_block_to_block (&block, &lbound_se.post);
}
}
}
/* Check string lengths if applicable. The check is only really added
to the output code if -fbounds-check is enabled. */
@ -4835,8 +4978,31 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
strlen_lhs, strlen_rhs, &block);
}
/* If rank remapping was done, check with -fcheck=bounds that
the target is at least as large as the pointer. */
if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
{
tree lsize, rsize;
tree fault;
const char* msg;
lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
lsize = gfc_evaluate_now (lsize, &block);
rsize = gfc_evaluate_now (rsize, &block);
fault = fold_build2 (LT_EXPR, boolean_type_node, rsize, lsize);
msg = _("Target of rank remapping is too small (%ld < %ld)");
gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
msg, rsize, lsize);
}
gfc_add_block_to_block (&block, &lse.post);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.post);
}
return gfc_finish_block (&block);
}

View File

@ -64,6 +64,13 @@ typedef struct gfc_se
pointer assignments. */
unsigned direct_byref:1;
/* If direct_byref is set, do work out the descriptor as in that case but
do still create a new descriptor variable instead of using an
existing one. This is useful for special pointer assignments like
rank remapping where we have to process the descriptor before
assigning to final one. */
unsigned byref_noassign:1;
/* Ignore absent optional arguments. Used for some intrinsics. */
unsigned ignore_optional:1;

View File

@ -1,3 +1,15 @@
2010-08-19 Daniel Kraft <d@domob.eu>
PR fortran/29785
PR fortran/45016
* gfortran.dg/pointer_assign_5.f90: Remove 'not implemented' error.
* gfortran.dg/pointer_remapping_1.f90: New test.
* gfortran.dg/pointer_remapping_2.f03: New test.
* gfortran.dg/pointer_remapping_3.f08: New test.
* gfortran.dg/pointer_remapping_4.f03: New test.
* gfortran.dg/pointer_remapping_5.f08: New test.
* gfortran.dg/pointer_remapping_6.f08: New test.
2010-08-19 Uros Bizjak <ubizjak@gmail.com>
PR testsuite/45324

View File

@ -1,9 +1,10 @@
! { dg-do compile }
! PR fortran/37580
!
! See also the pointer_remapping_* tests.
program test
implicit none
real, pointer :: ptr1(:), ptr2(:)
ptr1(1) => ptr2 ! { dg-error "Expected bounds specification" }
ptr1(1:) => ptr2 ! { dg-error "not yet implemented in gfortran" }
end program test

View File

@ -0,0 +1,19 @@
! { dg-do compile }
! { dg-options "-std=f95" }
! PR fortran/29785
! PR fortran/45016
! Check for F2003 rejection of pointer remappings.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: arr(12)
INTEGER, POINTER :: vec(:), mat(:, :)
vec => arr ! This is ok.
vec(2:) => arr ! { dg-error "Fortran 2003" }
mat(1:2, 1:6) => arr ! { dg-error "Fortran 2003" }
END PROGRAM main

View File

@ -0,0 +1,20 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
! PR fortran/29785
! Check for F2008 rejection of rank remapping to rank-two base array.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: arr(12), basem(3, 4)
INTEGER, POINTER :: vec(:), mat(:, :)
! These are ok.
vec => arr
vec(2:) => arr
mat(1:2, 1:6) => arr
vec(1:12) => basem ! { dg-error "Fortran 2008" }
END PROGRAM main

View File

@ -0,0 +1,35 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
! PR fortran/29785
! PR fortran/45016
! Check for pointer remapping compile-time errors.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: arr(12), basem(3, 4)
INTEGER, POINTER :: vec(:), mat(:, :)
! Existence of reference elements.
vec(:) => arr ! { dg-error "Lower bound has to be present" }
vec(5:7:1) => arr ! { dg-error "Stride must not be present" }
mat(1:, 2:5) => arr ! { dg-error "Either all or none of the upper bounds" }
mat(2, 6) => arr ! { dg-error "Expected bounds specification" }
! This is bound remapping not rank remapping!
mat(1:, 3:) => arr ! { dg-error "Different ranks" }
! Invalid remapping target; for non-rank one we already check the F2008
! error elsewhere. Here, test that not-contiguous target is disallowed
! with rank > 1.
mat(1:2, 1:3) => arr(1:12:2) ! This is ok, rank one target.
vec(1:8) => basem(1:3:2, :) ! { dg-error "rank 1 or simply contiguous" }
! Target is smaller than pointer.
vec(1:20) => arr ! { dg-error "smaller than size of the pointer" }
vec(1:10) => arr(1:12:2) ! { dg-error "smaller than size of the pointer" }
vec(1:20) => basem(:, :) ! { dg-error "smaller than size of the pointer" }
mat(1:5, 1:5) => arr ! { dg-error "smaller than size of the pointer" }
END PROGRAM main

View File

@ -0,0 +1,33 @@
! { dg-do run }
! { dg-options "-std=f2003 -fall-intrinsics -fcheck=bounds" }
! PR fortran/45016
! Check pointer bounds remapping at runtime.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: arr(2_2:5), basem(-2:-1, 3:4_1)
INTEGER, POINTER :: vec(:), vec2(:), mat(:, :)
arr = (/ 1, 2, 3, 4 /)
basem = RESHAPE (arr, SHAPE (basem))
vec(0:) => arr
IF (LBOUND (vec, 1) /= 0 .OR. UBOUND (vec, 1) /= 3) CALL abort ()
IF (ANY (vec /= arr)) CALL abort ()
IF (vec(0) /= 1 .OR. vec(2) /= 3) CALL abort ()
! Test with bound different of index type, so conversion is necessary.
vec2(-5_1:) => vec
IF (LBOUND (vec2, 1) /= -5 .OR. UBOUND (vec2, 1) /= -2) CALL abort ()
IF (ANY (vec2 /= arr)) CALL abort ()
IF (vec2(-5) /= 1 .OR. vec2(-3) /= 3) CALL abort ()
mat(1:, 2:) => basem
IF (ANY (LBOUND (mat) /= (/ 1, 2 /) .OR. UBOUND (mat) /= (/ 2, 3 /))) &
CALL abort ()
IF (ANY (mat /= basem)) CALL abort ()
IF (mat(1, 2) /= 1 .OR. mat(1, 3) /= 3 .OR. mat(2, 3) /= 4) CALL abort ()
END PROGRAM main

View File

@ -0,0 +1,37 @@
! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics -fcheck=bounds" }
! PR fortran/29785
! Check pointer rank remapping at runtime.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, TARGET :: arr(12), basem(3, 4)
INTEGER, POINTER :: vec(:), mat(:, :)
INTEGER :: i
arr = (/ (i, i = 1, 12) /)
basem = RESHAPE (arr, SHAPE (basem))
! We need not necessarily change the rank...
vec(2_1:5) => arr(1_1:12_1:2_1)
IF (LBOUND (vec, 1) /= 2 .OR. UBOUND (vec, 1) /= 5) CALL abort ()
IF (ANY (vec /= (/ 1, 3, 5, 7 /))) CALL abort ()
IF (vec(2) /= 1 .OR. vec(5) /= 7) CALL abort ()
! ...but it is of course the more interesting. Also try remapping a pointer.
vec => arr(1:12:2)
mat(1:3, 1:2) => vec
IF (ANY (LBOUND (mat) /= (/ 1, 1 /) .OR. UBOUND (mat) /= (/ 3, 2 /))) &
CALL abort ()
IF (ANY (mat /= RESHAPE (arr(1:12:2), SHAPE (mat)))) CALL abort ()
IF (mat(1, 1) /= 1 .OR. mat(1, 2) /= 7) CALL abort ()
! Remap with target of rank > 1.
vec(1:12_1) => basem
IF (LBOUND (vec, 1) /= 1 .OR. UBOUND (vec, 1) /= 12) CALL abort ()
IF (ANY (vec /= arr)) CALL abort ()
IF (vec(1) /= 1 .OR. vec(5) /= 5 .OR. vec(12) /= 12) CALL abort ()
END PROGRAM main

View File

@ -0,0 +1,29 @@
! { dg-do run }
! { dg-options "-std=f2008 -fcheck=bounds" }
! { dg-shouldfail "Bounds check" }
! PR fortran/29785
! Check that -fcheck=bounds catches too small target at runtime for
! pointer rank remapping.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
INTEGER, POINTER :: ptr(:, :)
INTEGER :: n
n = 10
BLOCK
INTEGER, TARGET :: arr(2*n)
! These are ok.
ptr(1:5, 1:2) => arr
ptr(1:5, 1:2) => arr(::2)
ptr(-5:-1, 11:14) => arr
! This is not.
ptr(1:3, 1:5) => arr(::2)
END BLOCK
END PROGRAM main
! { dg-output "At line 26 of .*\nFortran runtime error: Target of rank remapping is too small \\(10 < 15\\)" }