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
Daniel Kraft
parent
f1b62c9f96
commit
99d821c01c
15 changed files with 608 additions and 108 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
19
gcc/testsuite/gfortran.dg/pointer_remapping_1.f90
Normal file
19
gcc/testsuite/gfortran.dg/pointer_remapping_1.f90
Normal 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
|
||||
20
gcc/testsuite/gfortran.dg/pointer_remapping_2.f03
Normal file
20
gcc/testsuite/gfortran.dg/pointer_remapping_2.f03
Normal 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
|
||||
35
gcc/testsuite/gfortran.dg/pointer_remapping_3.f08
Normal file
35
gcc/testsuite/gfortran.dg/pointer_remapping_3.f08
Normal 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
|
||||
33
gcc/testsuite/gfortran.dg/pointer_remapping_4.f03
Normal file
33
gcc/testsuite/gfortran.dg/pointer_remapping_4.f03
Normal 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
|
||||
37
gcc/testsuite/gfortran.dg/pointer_remapping_5.f08
Normal file
37
gcc/testsuite/gfortran.dg/pointer_remapping_5.f08
Normal 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
|
||||
29
gcc/testsuite/gfortran.dg/pointer_remapping_6.f08
Normal file
29
gcc/testsuite/gfortran.dg/pointer_remapping_6.f08
Normal 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\\)" }
|
||||
Loading…
Add table
Reference in a new issue