diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 18 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 86 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 183 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 33 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 192 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 7 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_assign_5.f90 | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 | 35 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 | 33 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 | 37 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 | 29 |
15 files changed, 608 insertions, 108 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f5971dd54dc..90d26fbc469 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3d9f6dc61bf..959546672e0 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index cca4ecc4d9c..e355901f750 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); - - /* 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); + gfc_conv_descriptor_stride_set (pblock, descriptor, + gfc_rank_cst[n], stride); - 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) diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2e491c8c16b..a0d5ca128e1 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index f3e29502054..ea397096de2 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); - 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. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 810212ba9cf..63e674681b3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3c80ce7f26c..d5f82aa29c6 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e907c62644f..8867dee32f5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_5.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_5.f90 index 03562caf590..1994ffebb7e 100644 --- a/gcc/testsuite/gfortran.dg/pointer_assign_5.f90 +++ b/gcc/testsuite/gfortran.dg/pointer_assign_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 b/gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 new file mode 100644 index 00000000000..d360c4223cc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 b/gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 new file mode 100644 index 00000000000..57ec5c87237 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 b/gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 new file mode 100644 index 00000000000..376adb07afc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 b/gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 new file mode 100644 index 00000000000..d196ddeb0d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 b/gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 new file mode 100644 index 00000000000..28c0a7d8da6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 b/gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 new file mode 100644 index 00000000000..6a4e138f9e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 @@ -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\\)" } |