From patchwork Thu Aug 19 11:00:51 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 62136 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 71D64B70DD for ; Thu, 19 Aug 2010 20:56:03 +1000 (EST) Received: (qmail 26858 invoked by alias); 19 Aug 2010 10:56:00 -0000 Received: (qmail 26810 invoked by uid 22791); 19 Aug 2010 10:55:53 -0000 X-SWARE-Spam-Status: No, hits=-1.2 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 19 Aug 2010 10:55:40 +0000 Received: from pam.xoc.tele2net.at ([213.90.36.6]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1Om2mW-0002wS-Rg; Thu, 19 Aug 2010 12:55:36 +0200 Received: from d86-33-197-110.cust.tele2.at ([86.33.197.110] helo=[192.168.1.18]) by pam.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1Om2mV-0008Ub-SM; Thu, 19 Aug 2010 12:55:36 +0200 Message-ID: <4C6D0EE3.4050905@domob.eu> Date: Thu, 19 Aug 2010 13:00:51 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: [Patch, Fortran] Pointer remapping Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Hi, the attached patch implements pointer bounds remapping (F2003, see PR 45016) and pointer rank remapping (F2003 and generalized in F2008, see PR 29785). To my knowledge, these two new features should be fully supported with it. -fcheck=bounds was extended to check for invalid rank remapping assignment (target is smaller than the declared bounds for the pointer). I wonder whether we should print a warning (for instance with -Wsurprising) when the sizes are known at compile-time and the target is strictly larger than the declared bounds -- this is valid, but I'm not sure whether it is useful or will happen most of the time accidentally. Suggestions? My current plan is to leave it like that, i.e., no warning. But it is fairly trivial to add the warning. Currently regtesting on GNU/Linux-x86-32. Ok for trunk if no regressions? Yours, Daniel Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 163310) +++ gcc/fortran/trans-expr.c (working copy) @@ -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); } Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (revision 163310) +++ gcc/fortran/trans-array.c (working copy) @@ -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) Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (revision 163310) +++ gcc/fortran/trans-array.h (working copy) @@ -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); Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 163310) +++ gcc/fortran/expr.c (working copy) @@ -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; Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 163310) +++ gcc/fortran/trans.h (working copy) @@ -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; Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 163310) +++ gcc/fortran/trans-decl.c (working copy) @@ -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. */ Index: gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_6.f08 (revision 0) @@ -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\\)" } Index: gcc/testsuite/gfortran.dg/pointer_assign_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_assign_5.f90 (revision 163310) +++ gcc/testsuite/gfortran.dg/pointer_assign_5.f90 (working copy) @@ -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 Index: gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 =================================================================== --- gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 (revision 0) @@ -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