===================================================================
@@ -4762,21 +4762,46 @@ gfc_trans_pointer_assignment (gfc_expr *
}
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 decriptor 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;
@@ -4795,13 +4820,11 @@ gfc_trans_pointer_assignment (gfc_expr *
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;
@@ -4809,10 +4832,127 @@ gfc_trans_pointer_assignment (gfc_expr *
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 = gfc_evaluate_now (lower_se.expr, &block);
+ ubound = gfc_evaluate_now (upper_se.expr, &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. */
@@ -4824,8 +4964,31 @@ gfc_trans_pointer_assignment (gfc_expr *
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);
}
===================================================================
@@ -382,6 +382,37 @@ 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;
+
+ 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 +3815,62 @@ gfc_conv_loop_setup (gfc_loopinfo * loop
}
+/* 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 +3879,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop
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 +3901,6 @@ gfc_array_init_size (tree descriptor, in
tree size;
tree offset;
tree stride;
- tree cond;
tree or_expr;
tree thencase;
tree elsecase;
@@ -3834,14 +3920,17 @@ gfc_array_init_size (tree descriptor, in
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 +3940,41 @@ gfc_array_init_size (tree descriptor, in
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 +3994,16 @@ gfc_array_init_size (tree descriptor, in
}
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 +4014,8 @@ gfc_array_init_size (tree descriptor, in
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 +5143,7 @@ gfc_conv_expr_descriptor (gfc_se * se, g
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 +5348,7 @@ gfc_conv_expr_descriptor (gfc_se * se, g
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 +5506,7 @@ gfc_conv_expr_descriptor (gfc_se * se, g
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 (stm
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_constructo
/* 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);
===================================================================
@@ -3232,7 +3232,7 @@ gfc_check_pointer_assign (gfc_expr *lval
{
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 *lval
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 *lval
if (ref->type == REF_ARRAY && ref->next == NULL)
{
+ int dim;
+
if (ref->u.ar.type == AR_FULL)
break;
@@ -3285,16 +3288,42 @@ gfc_check_pointer_assign (gfc_expr *lval
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 for bounds"
+ " remapping at %L", &lvalue->where);
+ return FAILURE;
+ }
+ if (ref->u.ar.stride[dim])
+ {
+ gfc_error ("Stride must not be present for bounds"
+ " remapping 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 for bounds remapping"
+ " at %L", &lvalue->where);
+ return FAILURE;
+ }
+ }
+ }
}
}
@@ -3456,13 +3485,47 @@ gfc_check_pointer_assign (gfc_expr *lval
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 with rank not one must be"
+ " simply contiguous at %L", &rvalue->where);
+ return FAILURE;
+ }
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping with"
+ " target of rank not one 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;
===================================================================
@@ -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;
===================================================================
@@ -3133,42 +3133,15 @@ trans_associate_var (gfc_symbol* sym, gf
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);
- 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);
-
+ temporary), shift bounds so we get lower bounds of 1. */
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. */
===================================================================
@@ -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
===================================================================
@@ -0,0 +1,32 @@
+! { 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:5), basem(-2:-1, 3:4)
+ 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 ()
+
+ vec2(-5:) => 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
===================================================================
@@ -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\\)" }
===================================================================
@@ -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
===================================================================
@@ -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 "must be 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
===================================================================
@@ -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
===================================================================
@@ -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:5) => arr(1:12:2)
+ 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) => 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