+2010-11-28 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/35810
+ * trans-array.c (gfc_trans_array_constructor): If the loop->to
+ is a VAR_DECL, assume this is dynamic. In this case, use the
+ counter to obtain the value and set loop->to appropriately.
+ (gfc_conv_ss_descriptor): Always save the offset of a variable
+ in info.saved_offset.
+ (gfc_conv_ss_startstride): Do not attempt bound checking of the
+ lhs of an assignment, if allocatable and f2003 is allowed.
+ (gfc_conv_loop_setup): If possible, do not use an allocatable
+ lhs variable for the loopspec.
+ (gfc_is_reallocatable_lhs): New function.
+ (get_std_lbound): New function.
+ (gfc_alloc_allocatable_for_assignment): New function.
+ * gfortran.h : Add flag_realloc_lhs to the options structure.
+ * lang.opt : Add option f(no-)realloc-lhs.
+ * invoke.texi : Document option f(no-)realloc-lhs.
+ * options.c (gfc_init_options, gfc_post_options,
+ gfc_handle_option): Incorporate f(no-)realloc-lhs with default
+ to frealloc_lhs for -std > f95.
+ * trans-array.h : Add primitive for previous.
+ * trans-expr.c (gfc_conv_string_length): Return if character
+ length is a variable and the expression is NULL.
+ (gfc_conv_procedure_call): If the call is of the kind x = f(...)
+ and the lhs is allocatable and reallocation on assignment OK,
+ call gfc_alloc_allocatable_for_assignment. Do not generate the
+ function call unless direct by reference.
+ (realloc_lhs_loop_for_fcn_call): New function.
+ (realloc_lhs_bounds_for_intrinsic_call): New function.
+ (gfc_trans_arrayfunc_assign): Reallocation assignments need
+ a loopinfo and for the loop bounds to be set. With intrinsic
+ functions, free the lhs data and let the library allocate the
+ data array. Done by the new functions above.
+ (gfc_trans_assignment_1): If the lhs is allocatable and
+ reallocation on assignment is allowed, mark the lhs and use
+ gfc_alloc_allocatable_for_assignment to make the reallocation.
+ * trans.h : Add is_alloc_lhs bitfield to gfc_ss structure.
+
2010-11-27 Tobias Burnus <burnus@net-b.de>
Jerry DeLisle <jvdelisle@gcc.gnu.org>
int flag_align_commons;
int flag_whole_file;
int flag_protect_parens;
+ int flag_realloc_lhs;
int fpe;
int rtcheck;
-fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
-finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan|snan>} @gol
-finit-logical=@var{<true|false>} -finit-character=@var{n} @gol
--fno-align-commons -fno-protect-parens}
+-fno-align-commons -fno-protect-parens -frealloc-lhs}
@end table
@menu
@code{COMPLEX} expressions to produce faster code. Note that for the re-association
optimization @option{-fno-signed-zeros} and @option{-fno-trapping-math}
need to be in effect.
+
+@item -frealloc-lhs
+@opindex @code{frealloc-lhs}
+@cindex Reallocate the LHS in assignments
+An allocatable left-hand side of an intrinsic assignment is automatically
+(re)allocated if it is either unallocated or has a different shape. The
+option is enabled by default except when @option{-std=f95} is given.
@end table
@xref{Code Gen Options,,Options for Code Generation Conventions,
Fortran
Enable range checking during compilation
+frealloc-lhs
+Fortran
+Reallocate the LHS in assignments
+
frecord-marker=4
Fortran RejectNegative
Use a 4-byte record marker for unformatted files
gfc_option.flag_init_character_value = (char)0;
gfc_option.flag_align_commons = 1;
gfc_option.flag_protect_parens = 1;
+ gfc_option.flag_realloc_lhs = -1;
gfc_option.fpe = 0;
gfc_option.rtcheck = 0;
if (flag_associative_math == -1)
flag_associative_math = (!flag_trapping_math && !flag_signed_zeros);
+ /* By default, disable (re)allocation during assignment for -std=f95,
+ and enable it for F2003/F2008/GNU/Legacy. */
+ if (gfc_option.flag_realloc_lhs == -1)
+ {
+ if (gfc_option.allow_std & GFC_STD_F2003)
+ gfc_option.flag_realloc_lhs = 1;
+ else
+ gfc_option.flag_realloc_lhs = 0;
+ }
+
/* -fbounds-check is equivalent to -fcheck=bounds */
if (flag_bounds_check)
gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
gfc_option.flag_protect_parens = value;
break;
+ case OPT_frealloc_lhs:
+ gfc_option.flag_realloc_lhs = value;
+ break;
+
case OPT_fcheck_:
gfc_handle_runtime_check_option (arg);
break;
tree offsetvar;
tree desc;
tree type;
+ tree tmp;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
}
}
+ if (TREE_CODE (loop->to[0]) == VAR_DECL)
+ dynamic = true;
+
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
type, NULL_TREE, dynamic, true, false, where);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
- loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offsetvar, gfc_index_one_node);
+ tmp = gfc_evaluate_now (tmp, &loop->pre);
+ gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
+ if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL)
+ gfc_add_modify (&loop->pre, loop->to[0], tmp);
+ else
+ loop->to[0] = tmp;
+ }
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
else
gcc_assert (INTEGER_CST_P (offset));
+
#if 0
/* Disable bound checking for now because it's probably broken. */
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
tmp = gfc_conv_array_offset (se.expr);
ss->data.info.offset = gfc_evaluate_now (tmp, block);
+
+ /* Make absolutely sure that the saved_offset is indeed saved
+ so that the variable is still accessible after the loops
+ are translated. */
+ ss->data.info.saved_offset = ss->data.info.offset;
}
}
if (ss->type != GFC_SS_SECTION)
continue;
+ /* Catch allocatable lhs in f2003. */
+ if (gfc_option.flag_realloc_lhs && ss->is_alloc_lhs)
+ continue;
+
gfc_start_block (&inner);
/* TODO: range checking for mapped dimensions. */
continue;
}
+ /* Avoid using an allocatable lhs in an assignment, since
+ there might be a reallocation coming. */
+ if (loopspec[n] && ss->is_alloc_lhs)
+ continue;
+
if (ss->type != GFC_SS_SECTION)
continue;
}
+/* Returns the value of LBOUND for an expression. This could be broken out
+ from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
+ called by gfc_alloc_allocatable_for_assignment. */
+static tree
+get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+{
+ tree lbound;
+ tree ubound;
+ tree stride;
+ tree cond, cond1, cond3, cond4;
+ tree tmp;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ tmp = gfc_rank_cst[dim];
+ lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+ ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+ stride = gfc_conv_descriptor_stride_get (desc, tmp);
+ cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ ubound, lbound);
+ cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond3, cond1);
+ cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ if (assumed_size)
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ tmp, build_int_cst (gfc_array_index_type,
+ expr->rank - 1));
+ else
+ cond = boolean_false_node;
+
+ cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond3, cond4);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond, cond1);
+
+ return fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+ else if (expr->expr_type == EXPR_VARIABLE)
+ {
+ tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+ return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+ }
+ else if (expr->expr_type == EXPR_FUNCTION)
+ {
+ /* A conversion function, so use the argument. */
+ expr = expr->value.function.actual->expr;
+ if (expr->expr_type != EXPR_VARIABLE)
+ return gfc_index_one_node;
+ desc = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+ return get_std_lbound (expr, desc, dim, assumed_size);
+ }
+
+ return gfc_index_one_node;
+}
+
+
+/* Returns true if an expression represents an lhs that can be reallocated
+ on assignment. */
+
+bool
+gfc_is_reallocatable_lhs (gfc_expr *expr)
+{
+ gfc_ref * ref;
+
+ if (!expr->ref)
+ return false;
+
+ /* An allocatable variable. */
+ if (expr->symtree->n.sym->attr.allocatable
+ && expr->ref
+ && expr->ref->type == REF_ARRAY
+ && expr->ref->u.ar.type == AR_FULL)
+ return true;
+
+ /* All that can be left are allocatable components. */
+ if (expr->symtree->n.sym->ts.type != BT_DERIVED
+ || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+ return false;
+
+ /* Find a component ref followed by an array reference. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->next
+ && ref->type == REF_COMPONENT
+ && ref->next->type == REF_ARRAY
+ && !ref->next->next)
+ break;
+
+ if (!ref)
+ return false;
+
+ /* Return true if valid reallocatable lhs. */
+ if (ref->u.c.component->attr.allocatable
+ && ref->next->u.ar.type == AR_FULL)
+ return true;
+
+ return false;
+}
+
+
+/* Allocate the lhs of an assignment to an allocatable array, otherwise
+ reallocate it. */
+
+tree
+gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
+ gfc_expr *expr1,
+ gfc_expr *expr2)
+{
+ stmtblock_t realloc_block;
+ stmtblock_t alloc_block;
+ stmtblock_t fblock;
+ gfc_ss *rss;
+ gfc_ss *lss;
+ tree realloc_expr;
+ tree alloc_expr;
+ tree size1;
+ tree size2;
+ tree array1;
+ tree cond;
+ tree tmp;
+ tree tmp2;
+ tree lbound;
+ tree ubound;
+ tree desc;
+ tree desc2;
+ tree offset;
+ tree jump_label1;
+ tree jump_label2;
+ tree neq_size;
+ tree lbd;
+ int n;
+ int dim;
+ gfc_array_spec * as;
+
+ /* x = f(...) with x allocatable. In this case, expr1 is the rhs.
+ Find the lhs expression in the loop chain and set expr1 and
+ expr2 accordingly. */
+ if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
+ {
+ expr2 = expr1;
+ /* Find the ss for the lhs. */
+ lss = loop->ss;
+ for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+ if (lss->expr && lss->expr->expr_type == EXPR_VARIABLE)
+ break;
+ if (lss == gfc_ss_terminator)
+ return NULL_TREE;
+ expr1 = lss->expr;
+ }
+
+ /* Bail out if this is not a valid allocate on assignment. */
+ if (!gfc_is_reallocatable_lhs (expr1)
+ || (expr2 && !expr2->rank))
+ return NULL_TREE;
+
+ /* Find the ss for the lhs. */
+ lss = loop->ss;
+ for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
+ if (lss->expr == expr1)
+ break;
+
+ if (lss == gfc_ss_terminator)
+ return NULL_TREE;
+
+ /* Find an ss for the rhs. For operator expressions, we see the
+ ss's for the operands. Any one of these will do. */
+ rss = loop->ss;
+ for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
+ if (rss->expr != expr1 && rss != loop->temp_ss)
+ break;
+
+ if (expr2 && rss == gfc_ss_terminator)
+ return NULL_TREE;
+
+ gfc_start_block (&fblock);
+
+ /* Since the lhs is allocatable, this must be a descriptor type.
+ Get the data and array size. */
+ desc = lss->data.info.descriptor;
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+ array1 = gfc_conv_descriptor_data_get (desc);
+ size1 = gfc_conv_descriptor_size (desc, expr1->rank);
+
+ /* Get the rhs size. Fix both sizes. */
+ if (expr2)
+ desc2 = rss->data.info.descriptor;
+ else
+ desc2 = NULL_TREE;
+ size2 = gfc_index_one_node;
+ for (n = 0; n < expr2->rank; n++)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ tmp, size2);
+ }
+ size1 = gfc_evaluate_now (size1, &fblock);
+ size2 = gfc_evaluate_now (size2, &fblock);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ size1, size2);
+ neq_size = gfc_evaluate_now (cond, &fblock);
+
+ /* If the lhs is allocated and the lhs and rhs are equal length, jump
+ past the realloc/malloc. This allows F95 compliant expressions
+ to escape allocation on assignment. */
+ jump_label1 = gfc_build_label_decl (NULL_TREE);
+ jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+ /* Allocate if data is NULL. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ array1, build_int_cst (TREE_TYPE (array1), 0));
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ /* Reallocate if sizes are different. */
+ tmp = build3_v (COND_EXPR, neq_size,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ if (expr2 && expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
+ && expr2->value.function.isym->conversion)
+ {
+ /* For conversion functions, take the arg. */
+ gfc_expr *arg = expr2->value.function.actual->expr;
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ }
+ else if (expr2)
+ as = gfc_get_full_arrayspec_from_expr (expr2);
+ else
+ as = NULL;
+
+ /* Reset the lhs bounds if any are different from the rhs. */
+ if (as && expr2->expr_type == EXPR_VARIABLE)
+ {
+ for (n = 0; n < expr1->rank; n++)
+ {
+ /* First check the lbounds. */
+ dim = rss->data.info.dim[n];
+ lbd = get_std_lbound (expr2, desc2, dim,
+ as->type == AS_ASSUMED_SIZE);
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, lbd, lbound);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ /* Now check the shape. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, lbound);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ tmp, ubound);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ tmp, gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+ }
+ }
+
+ /* Otherwise jump past the (re)alloc code. */
+ tmp = build1_v (GOTO_EXPR, jump_label2);
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ /* Add the label to start automatic (re)allocation. */
+ tmp = build1_v (LABEL_EXPR, jump_label1);
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ /* Now modify the lhs descriptor and the associated scalarizer
+ variables.
+ 7.4.1.3: If variable is or becomes an unallocated allocatable
+ variable, then it is allocated with each deferred type parameter
+ equal to the corresponding type parameters of expr , with the
+ shape of expr , and with each lower bound equal to the
+ corresponding element of LBOUND(expr). */
+ size1 = gfc_index_one_node;
+ offset = gfc_index_zero_node;
+
+ for (n = 0; n < expr2->rank; n++)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+
+ lbound = gfc_index_one_node;
+ ubound = tmp;
+
+ if (as)
+ {
+ lbd = get_std_lbound (expr2, desc2, n,
+ as->type == AS_ASSUMED_SIZE);
+ ubound = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbound);
+ ubound = fold_build2_loc (input_location,
+ PLUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbd);
+ lbound = lbd;
+ }
+
+ gfc_conv_descriptor_lbound_set (&fblock, desc,
+ gfc_rank_cst[n],
+ lbound);
+ gfc_conv_descriptor_ubound_set (&fblock, desc,
+ gfc_rank_cst[n],
+ ubound);
+ gfc_conv_descriptor_stride_set (&fblock, desc,
+ gfc_rank_cst[n],
+ size1);
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ lbound, size1);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp2);
+ size1 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ tmp, size1);
+ }
+
+ /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
+ the array offset is saved and the info.offset is used for a
+ running offset. Use the saved_offset instead. */
+ tmp = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (&fblock, tmp, offset);
+ if (lss->data.info.saved_offset
+ && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL)
+ gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp);
+
+ /* Now set the deltas for the lhs. */
+ for (n = 0; n < expr1->rank; n++)
+ {
+ tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
+ dim = lss->data.info.dim[n];
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, tmp,
+ loop->from[dim]);
+ if (lss->data.info.delta[dim]
+ && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL)
+ gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp);
+ }
+
+ /* Get the new lhs size in bytes. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ gcc_assert (expr1->ts.u.cl->backend_decl);
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ }
+ else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+ {
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp,
+ expr1->ts.u.cl->backend_decl);
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ size2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ tmp, size2);
+ size2 = fold_convert (size_type_node, size2);
+ size2 = gfc_evaluate_now (size2, &fblock);
+
+ /* Realloc expression. Note that the scalarizer uses desc.data
+ in the array reference - (*desc.data)[<element>]. */
+ gfc_init_block (&realloc_block);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_REALLOC], 2,
+ fold_convert (pvoid_type_node, array1),
+ size2);
+ gfc_conv_descriptor_data_set (&realloc_block,
+ desc, tmp);
+ realloc_expr = gfc_finish_block (&realloc_block);
+
+ /* Only reallocate if sizes are different. */
+ tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
+ build_empty_stmt (input_location));
+ realloc_expr = tmp;
+
+
+ /* Malloc expression. */
+ gfc_init_block (&alloc_block);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MALLOC], 1,
+ size2);
+ gfc_conv_descriptor_data_set (&alloc_block,
+ desc, tmp);
+ tmp = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ alloc_expr = gfc_finish_block (&alloc_block);
+
+ /* Malloc if not allocated; realloc otherwise. */
+ tmp = build_int_cst (TREE_TYPE (array1), 0);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node,
+ array1, tmp);
+ tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ /* Make sure that the scalarizer data pointer is updated. */
+ if (lss->data.info.data
+ && TREE_CODE (lss->data.info.data) == VAR_DECL)
+ {
+ tmp = gfc_conv_descriptor_data_get (desc);
+ gfc_add_modify (&fblock, lss->data.info.data, tmp);
+ }
+
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, jump_label2);
+ gfc_add_expr_to_block (&fblock, tmp);
+
+ return gfc_finish_block (&fblock);
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*);
+
+bool gfc_is_reallocatable_lhs (gfc_expr *);
+
/* Add initialization for deferred arrays. */
void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *);
/* Generate an initializer for a static pointer or allocatable array. */
gfc_init_se (&se, NULL);
+ if (!cl->length
+ && cl->backend_decl
+ && TREE_CODE (cl->backend_decl) == VAR_DECL)
+ return;
+
/* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
"flatten" array constructors by taking their first element; all elements
should be the same length or a cl->length should be present. */
{
gfc_expr* expr_flat;
gcc_assert (expr);
-
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- result = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must do the automatic reallocation.
+ TODO - deal with instrinsics, without using a temporary. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->loop_chain
+ && se->ss->loop_chain->is_alloc_lhs
+ && !expr->value.function.isym
+ && sym->result->as != NULL)
+ {
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se,
+ sym->result->as);
+
+ /* Perform the automatic reallocation. */
+ tmp = gfc_alloc_allocatable_for_assignment (se->loop,
+ expr, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Pass the temporary as the first argument. */
+ result = info->descriptor;
+ }
+ else
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
VEC_safe_push (tree, gc, retargs, se->expr);
}
else if (comp && comp->attr.dimension)
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create a temporary to store the result. In case the function
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create a temporary to store the result. In case the function
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
}
+/* Provide the loop info so that the lhs descriptor can be built for
+ reallocatable assignments from extrinsic function calls. */
+
+static void
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+{
+ gfc_loopinfo loop;
+ /* Signal that the function call should not be made by
+ gfc_conv_loop_setup. */
+ se->ss->is_alloc_lhs = 1;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, *ss);
+ gfc_add_ss_to_loop (&loop, se->ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_copy_loopinfo_to_se (se, &loop);
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ se->ss->is_alloc_lhs = 0;
+}
+
+
+static void
+realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+{
+ tree desc;
+ tree tmp;
+ tree offset;
+ int n;
+
+ /* Use the allocation done by the library. */
+ desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+ /* Unallocated, the descriptor does not have a dtype. */
+ tmp = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+ offset = gfc_index_zero_node;
+ tmp = gfc_index_one_node;
+ /* Now reset the bounds from zero based to unity based. */
+ for (n = 0 ; n < rank; n++)
+ {
+ /* Accumulate the offset. */
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp);
+ /* Now do the bounds. */
+ gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+ tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_lbound_set (&se->post, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&se->post, desc,
+ gfc_rank_cst[n], tmp);
+
+ /* The extent for the next contribution to offset. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ }
+ gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+}
+
+
+
/* Try to translate array(:) = func (...), where func is a transformational
array function, without using a temporary. Returns NULL if this isn't the
case. */
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);
+
+ /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+ This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+ Clearly, this cannot be done for an allocatable function result, since
+ the shape of the result is unknown and, in any case, the function must
+ correctly take care of the reallocation internally. For intrinsic
+ calls, the array data is freed and the library takes care of allocation.
+ TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
+ to the library. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1)
+ && !(expr2->value.function.esym
+ && expr2->value.function.esym->result->attr.allocatable))
+ {
+ if (!expr2->value.function.isym)
+ {
+ realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+ ss->is_alloc_lhs = 1;
+ }
+ else
+ realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+ }
+
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
/* Walk the lhs. */
lss = gfc_walk_expr (expr1);
+ if (gfc_is_reallocatable_lhs (expr1)
+ && !(expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL))
+ lss->is_alloc_lhs = 1;
rss = NULL;
if (lss != gfc_ss_terminator)
{
gfc_add_expr_to_block (&body, tmp);
}
+ /* Allocate or reallocate lhs of allocatable array. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1))
+ {
+ tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+ }
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
break;
case BT_CHARACTER:
- basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+#if 0
+ if (spec->deferred)
+ basetype = gfc_get_character_type (spec->kind, NULL);
+ else
+#endif
+ basetype = gfc_get_character_type (spec->kind, spec->u.cl);
break;
case BT_DERIVED:
loops the terms appear in. This will be 1 for the RHS expressions,
2 for the LHS expressions, and 3(=1|2) for the temporary. The bit
'where' suppresses precalculation of scalars in WHERE assignments. */
- unsigned useflags:2, where:1;
+ unsigned useflags:2, where:1, is_alloc_lhs:1;
}
gfc_ss;
#define gfc_get_ss() XCNEW (gfc_ss)
+2010-11-28 Paul Thomas <pault@gcc.gnu.org
+
+ PR fortran/35810
+ * gfortran.dg/realloc_on_assign_1.f03: New test.
+ * gfortran.dg/realloc_on_assign_2.f03: New test.
+ * gfortran.dg/transpose_2.f90: dg-option -fno-realloc-lhs.
+ * gfortran.dg/unpack_bounds_1.f90: The same.
+ * gfortran.dg/cshift_bounds_2.f90: The same.
+ * gfortran.dg/matmul_bounds_2.f90: The same.
+ * gfortran.dg/matmul_bounds_3.f90: The same.
+ * gfortran.dg/matmul_bounds_4.f90: The same.
+ * gfortran.dg/matmul_bounds_5.f90: The same.
+
2010-11-27 Tobias Burnus <burnus@net-b.de>
PR fortran/46638
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" }
program main
integer, dimension(:,:), allocatable :: a, b
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 2: is 2, should be 3" }
program main
real, dimension(3,2) :: a
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
program main
real, dimension(3,2) :: a
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
program main
real, dimension(3) :: a
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic: is 3, should be 2" }
program main
real, dimension(2,3) :: a
--- /dev/null
+! { dg-do run }
+! Tests the patch that implements F2003 automatic allocation and
+! reallocation of allocatable arrays on assignment.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ integer(4), allocatable :: a(:), b(:), c(:,:)
+ integer(4) :: j
+ integer(4) :: src(2:5) = [11,12,13,14]
+ integer(4) :: mat(2:3,5:6)
+ character(4), allocatable :: chr1(:)
+ character(4) :: chr2(2) = ["abcd", "wxyz"]
+
+ allocate(a(1))
+ mat = reshape (src, [2,2])
+
+ a = [4,3,2,1]
+ if (size(a, 1) .ne. 4) call abort
+ if (any (a .ne. [4,3,2,1])) call abort
+
+ a = [((42 - i), i = 1, 10)]
+ if (size(a, 1) .ne. 10) call abort
+ if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+
+ b = a
+ if (size(b, 1) .ne. 10) call abort
+ if (any (b .ne. a)) call abort
+
+ a = [4,3,2,1]
+ if (size(a, 1) .ne. 4) call abort
+ if (any (a .ne. [4,3,2,1])) call abort
+
+ a = b
+ if (size(a, 1) .ne. 10) call abort
+ if (any (a .ne. [((42 - i), i = 1, 10)])) call abort
+
+ j = 20
+ a = [(i, i = 1, j)]
+ if (size(a, 1) .ne. j) call abort
+ if (any (a .ne. [(i, i = 1, j)])) call abort
+
+ a = foo (15)
+ if (size(a, 1) .ne. 15) call abort
+ if (any (a .ne. [((i + 15), i = 1, 15)])) call abort
+
+ a = src
+ if (lbound(a, 1) .ne. lbound(src, 1)) call abort
+ if (ubound(a, 1) .ne. ubound(src, 1)) call abort
+ if (any (a .ne. [11,12,13,14])) call abort
+
+ k = 7
+ a = b(k:8)
+ if (lbound(a, 1) .ne. lbound (b(k:8), 1)) call abort
+ if (ubound(a, 1) .ne. ubound (b(k:8), 1)) call abort
+ if (any (a .ne. [35,34])) call abort
+
+ c = mat
+ if (any (lbound (c) .ne. lbound (mat))) call abort
+ if (any (ubound (c) .ne. ubound (mat))) call abort
+ if (any (c .ne. mat)) call abort
+
+ deallocate (c)
+ c = mat(2:,:)
+ if (any (lbound (c) .ne. lbound (mat(2:,:)))) call abort
+
+ chr1 = chr2(2:1:-1)
+ if (lbound(chr1, 1) .ne. 1) call abort
+ if (any (chr1 .ne. chr2(2:1:-1))) call abort
+
+ b = c(1, :) + c(2, :)
+ if (lbound(b, 1) .ne. lbound (c(1, :) + c(2, :), 1)) call abort
+ if (any (b .ne. c(1, :) + c(2, :))) call abort
+contains
+ function foo (n) result(res)
+ integer(4), allocatable, dimension(:) :: res
+ integer(4) :: n
+ allocate (res(n))
+ res = [((i + 15), i = 1, n)]
+ end function foo
+end
--- /dev/null
+! { dg-do run }
+! Tests the patch that implements F2003 automatic allocation and
+! reallocation of allocatable arrays on assignment. The tests
+! below were generated in the final stages of the development of
+! this patch.
+!
+! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
+! and Tobias Burnus <burnus@gcc.gnu.org>
+!
+ integer :: nglobal
+ call test1
+ call test2
+ call test3
+ call test4
+ call test5
+ call test6
+ call test7
+ call test8
+contains
+ subroutine test1
+!
+! Check that the bounds are set correctly, when assigning
+! to an array that already has the correct shape.
+!
+ real :: a(10) = 1, b(51:60) = 2
+ real, allocatable :: c(:), d(:)
+ c=a
+ if (lbound (c, 1) .ne. lbound(a, 1)) call abort
+ if (ubound (c, 1) .ne. ubound(a, 1)) call abort
+ c=b
+ if (lbound (c, 1) .ne. lbound(b, 1)) call abort
+ if (ubound (c, 1) .ne. ubound(b, 1)) call abort
+ d=b
+ if (lbound (d, 1) .ne. lbound(b, 1)) call abort
+ if (ubound (d, 1) .ne. ubound(b, 1)) call abort
+ d=a
+ if (lbound (d, 1) .ne. lbound(a, 1)) call abort
+ if (ubound (d, 1) .ne. ubound(a, 1)) call abort
+ end subroutine
+ subroutine test2
+!
+! Check that the bounds are set correctly, when making an
+! assignment with an implicit conversion. First with a
+! non-descriptor variable....
+!
+ integer(4), allocatable :: a(:)
+ integer(8) :: b(5:6)
+ a = b
+ if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+ if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+ end subroutine
+ subroutine test3
+!
+! ...and now a descriptor variable.
+!
+ integer(4), allocatable :: a(:)
+ integer(8), allocatable :: b(:)
+ allocate (b(7:11))
+ a = b
+ if (lbound (a, 1) .ne. lbound(b, 1)) call abort
+ if (ubound (a, 1) .ne. ubound(b, 1)) call abort
+ end subroutine
+ subroutine test4
+!
+! Check assignments of the kind a = f(...)
+!
+ integer, allocatable :: a(:)
+ integer, allocatable :: c(:)
+ a = f()
+ if (any (a .ne. [1, 2, 3, 4])) call abort
+ c = a + 8
+ a = f (c)
+ if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort
+ deallocate (c)
+ a = f (c)
+ if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort
+ end subroutine
+ function f(b)
+ integer, allocatable, optional :: b(:)
+ integer :: f(4)
+ if (.not.present (b)) then
+ f = [1,2,3,4]
+ elseif (.not.allocated (b)) then
+ f = [5,6,7,8]
+ else
+ f = b
+ end if
+ end function f
+
+ subroutine test5
+!
+! Extracted from rnflow.f90, Polyhedron benchmark suite,
+! http://www.polyhedron.com
+!
+ integer, parameter :: ncls = 233, ival = 16, ipic = 17
+ real, allocatable, dimension (:,:) :: utrsft
+ real, allocatable, dimension (:,:) :: dtrsft
+ real, allocatable, dimension (:,:) :: xwrkt
+ allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls))
+ nglobal = 0
+ xwrkt = trs2a2 (ival, ipic, ncls)
+ if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort
+ xwrkt = invima (xwrkt, ival, ipic, ncls)
+ if (nglobal .ne. 1) call abort
+ if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort
+ end subroutine
+ function trs2a2 (j, k, m)
+ real, dimension (1:m,1:m) :: trs2a2
+ integer, intent (in) :: j, k, m
+ nglobal = nglobal + 1
+ trs2a2 = 0.0
+ end function trs2a2
+ function invima (a, j, k, m)
+ real, dimension (1:m,1:m) :: invima
+ real, dimension (1:m,1:m), intent (in) :: a
+ integer, intent (in) :: j, k
+ invima (j, j) = 1.0 / (1.0 - a (j, j))
+ end function invima
+ subroutine test6
+ character(kind=1, len=100), allocatable, dimension(:) :: str
+ str = [ "abc" ]
+ if (TRIM(str(1)) .ne. "abc") call abort
+ if (len(str) .ne. 100) call abort
+ end subroutine
+ subroutine test7
+ character(kind=4, len=100), allocatable, dimension(:) :: str
+ character(kind=4, len=3) :: test = "abc"
+ str = [ "abc" ]
+ if (TRIM(str(1)) .ne. test) call abort
+ if (len(str) .ne. 100) call abort
+ end subroutine
+ subroutine test8
+ type t
+ integer, allocatable :: a(:)
+ end type t
+ type(t) :: x
+ x%a= [1,2,3]
+ if (any (x%a .ne. [1,2,3])) call abort
+ x%a = [4]
+ if (any (x%a .ne. [4])) call abort
+ end subroutine
+end
+
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Incorrect extent in return value of TRANSPOSE intrinsic in dimension 1: is 2, should be 3" }
program main
implicit none
! { dg-do run }
-! { dg-options "-fbounds-check" }
+! { dg-options "-fbounds-check -fno-realloc-lhs" }
! { dg-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
program main
integer, allocatable, dimension(:) :: vector
OSDN Git Service
