OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/35810 ([TR 15581 / F2003] Automatic reallocation on assignment to allocatable variables) 

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-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.

From-SVN: r167220
This commit is contained in:
Paul Thomas 2010-11-28 13:47:26 +00:00
parent 18af637ed9
commit 597553ab3c
20 changed files with 963 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/fortran/ChangeLog
View File

@ -1,3 +1,42 @@
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>

1
gcc/fortran/gfortran.h
View File

@ -2238,6 +2238,7 @@ typedef struct
int flag_align_commons;
int flag_whole_file;
int flag_protect_parens;
int flag_realloc_lhs;
int fpe;
int rtcheck;

9
gcc/fortran/invoke.texi
View File

@ -171,7 +171,7 @@ 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}
-fno-align-commons -fno-protect-parens -frealloc-lhs}
@end table
@menu
@ -1458,6 +1458,13 @@ levels such that the compiler does not do any re-association. Using
@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,

4
gcc/fortran/lang.opt
View File

@ -474,6 +474,10 @@ 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

15
gcc/fortran/options.c
View File

@ -149,6 +149,7 @@ gfc_init_options (unsigned int decoded_options_count,
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;
@ -266,6 +267,16 @@ 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;
@ -964,6 +975,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
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;

477
gcc/fortran/trans-array.c
View File

@ -1837,6 +1837,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
tree offsetvar;
tree desc;
tree type;
tree tmp;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
@ -1949,6 +1950,9 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
}
}
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);
@ -1963,12 +1967,23 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * 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)
@ -2181,6 +2196,11 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
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;
}
}
@ -3209,6 +3229,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
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. */
@ -3676,6 +3700,11 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
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;
@ -6457,6 +6486,452 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
}
/* 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. */

4
gcc/fortran/trans-array.h
View File

@ -57,6 +57,10 @@ tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
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. */

169
gcc/fortran/trans-expr.c
View File

@ -335,6 +335,11 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
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. */
@ -342,7 +347,6 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
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);
@ -3355,8 +3359,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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)
@ -3370,6 +3396,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* 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. */
@ -3394,6 +3431,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* 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. */
@ -5331,6 +5379,81 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
}
/* 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. */
@ -5373,6 +5496,31 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
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);
@ -5603,6 +5751,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* 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)
{
@ -5748,6 +5900,17 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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);

7
gcc/fortran/trans-types.c
View File

@ -1048,7 +1048,12 @@ gfc_typenode_for_spec (gfc_typespec * spec)
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:

2
gcc/fortran/trans.h
View File

@ -216,7 +216,7 @@ 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;
unsigned useflags:2, where:1, is_alloc_lhs:1;
}
gfc_ss;
#define gfc_get_ss() XCNEW (gfc_ss)

13
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,16 @@
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

2
gcc/testsuite/gfortran.dg/cshift_bounds_2.f90
View File

@ -1,5 +1,5 @@
! { 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

2
gcc/testsuite/gfortran.dg/matmul_bounds_2.f90
View File

@ -1,5 +1,5 @@
! { 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

2
gcc/testsuite/gfortran.dg/matmul_bounds_3.f90
View File

@ -1,5 +1,5 @@
! { 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

2
gcc/testsuite/gfortran.dg/matmul_bounds_4.f90
View File

@ -1,5 +1,5 @@
! { 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

2
gcc/testsuite/gfortran.dg/matmul_bounds_5.f90
View File

@ -1,5 +1,5 @@
! { 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

80
gcc/testsuite/gfortran.dg/realloc_on_assign_1.f03 Normal file
View File

@ -0,0 +1,80 @@
! { 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

143
gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 Normal file
View File

@ -0,0 +1,143 @@
! { 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

2
gcc/testsuite/gfortran.dg/transpose_2.f90
View File

@ -1,5 +1,5 @@
! { 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

2
gcc/testsuite/gfortran.dg/unpack_bounds_1.f90
View File

@ -1,5 +1,5 @@
! { 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