===================================================================
*************** gfc_conv_string_length (gfc_charlen * cl
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_conv_string_length (gfc_charlen * cl
{
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);
*************** gfc_conv_procedure_call (gfc_se * se, gf
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
! result = build_fold_indirect_ref_loc (input_location,
! se->expr);
VEC_safe_push (tree, gc, retargs, se->expr);
}
else if (comp && comp->attr.dimension)
se->expr = 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)
*************** gfc_conv_procedure_call (gfc_se * se, gf
/* 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. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
/* 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. */
*************** arrayfunc_assign_needs_temporary (gfc_ex
}
+ /* 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. */
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
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);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
/* 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_trans_assignment_1 (gfc_expr * expr1
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);
===================================================================
*************** gfc_trans_array_constructor (gfc_loopinf
tree offsetvar;
tree desc;
tree type;
+ tree tmp;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
*************** gfc_trans_array_constructor (gfc_loopinf
}
}
+ 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);
*************** gfc_trans_array_constructor (gfc_loopinf
/* 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]);
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)
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
! {
! 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)
*************** gfc_conv_ss_descriptor (stmtblock_t * bl
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;
}
}
*************** gfc_conv_ss_startstride (gfc_loopinfo *
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. */
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
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;
*************** gfc_copy_only_alloc_comp (gfc_symbol * d
}
+ /* 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_alloc_comp (gfc_symbol *,
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. */
===================================================================
*************** typedef struct
int flag_align_commons;
int flag_whole_file;
int flag_protect_parens;
+ int flag_realloc_lhs;
int fpe;
int rtcheck;
===================================================================
*************** frange-check
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
===================================================================
*************** and warnings}.
-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}
@end table
@menu
-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 -frealloc-lhs}
@end table
@menu
*************** levels such that the compiler does not d
@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,
===================================================================
*************** typedef struct gfc_ss
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;
}
gfc_ss;
#define gfc_get_ss() XCNEW (gfc_ss)
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, is_alloc_lhs:1;
}
gfc_ss;
#define gfc_get_ss() XCNEW (gfc_ss)
===================================================================
*************** gfc_init_options (unsigned int decoded_o
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;
*************** gfc_post_options (const char **pfilename
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_handle_option (size_t scode, const c
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;
===================================================================
***************
! { dg-do run }
! ! { dg-options "-fbounds-check" }
! { 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 -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-shouldfail "Incorrect extent in return value of UNPACK intrinsic in dimension 2: is 1, should be 2" }
program main
integer, allocatable, dimension(:) :: vector
! { dg-do run }
! ! { 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
===================================================================
***************
! { dg-do run }
! ! { dg-options "-fbounds-check" }
! { 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 -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-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 -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 }
+ ! 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
===================================================================
***************
! { dg-do run }
! ! { dg-options "-fbounds-check" }
! { 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
! { dg-do run }
! ! { 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
===================================================================
***************
! { dg-do run }
! ! { dg-options "-fbounds-check" }
! { 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 -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-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 -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 }
+ ! 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
+