This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Wed, 29 Aug 2007 20:02:14 +0200
- Subject: [Patch, fortran] PR31879 , PR31197 , PR31258 & PR32703 - various character problems
:ADDPATCH fortran:
This patch removes some kludges for character expressions from
translation and adds a comprehensive fix for the remaining character
problems to resolution. The latter, in principle, ensures that a
character expression also has a character length expression. These are
then translated using gfc_trans_init_string_length, which has been
renamed to gfc_conv_string_length, both to reflect the convention
described in trans.c and its more general use.
The development relative to the version of 20070615 is that the final
test in character_length_7.f90 is fixed and the extraneous code removed
from trans-array.c and trans-expr.c.
I am certain that were I to say that this is an end to this kind of bug,
all hell would break loose :-) However, the patch is a step in that
direction......
The testcases are based on the reporters'.
Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?
Paul
2007-08-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31879
PR fortran/31197
PR fortran/31258
PR fortran/32703
* gfortran.h : Add prototype for gfc_resolve_substring_charlen.
* resolve.c (gfc_resolve_substring_charlen): New function.
(resolve_ref): Call gfc_resolve_substring_charlen.
(gfc_resolve_character_operator): New function.
(gfc_resolve_expr): Call the new functions in cases where the
character length is missing.
* iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
transpose, unpack): Call gfc_resolve_substring_charlen for
source expressions that are character and have a reference.
* trans.h (gfc_trans_init_string_length) Change name to
gfc_conv_string_length; modify references in trans-expr.c,
trans-array.c and trans-decl.c.
* trans-expr.c (gfc_trans_string_length): Handle case of no
backend_decl.
(gfc_conv_aliased_arg): Remove code for treating substrings
and replace with call to gfc_trans_string_length.
* trans-array.c (gfc_conv_expr_descriptor): Remove code for
treating strings and call gfc_trans_string_length instead.
2007-08-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31879
* gfortran.dg/char_length_7.f90: New test.
* gfortran.dg/char_assign_1.f90: Add extra warning.
PR fortran/31197
PR fortran/31258
* gfortran.dg/char_length_8.f90: New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 127610)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_expr_charlen (gfc_expr *e)
*** 220,229 ****
value. */
void
! gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
{
gfc_se se;
- tree tmp;
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
--- 220,228 ----
value. */
void
! gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
{
gfc_se se;
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
*************** gfc_trans_init_string_length (gfc_charle
*** 231,238 ****
build_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre);
! tmp = cl->backend_decl;
! gfc_add_modify_expr (pblock, tmp, se.expr);
}
--- 230,239 ----
build_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre);
! if (cl->backend_decl)
! gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
! else
! cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1823,1828 ****
--- 1824,1832 ----
gfc_conv_ss_startstride (&loop);
/* Build an ss for the temporary. */
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
|| GFC_DESCRIPTOR_TYPE_P (base_type))
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1833,1871 ****
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
! {
! gfc_ref *char_ref = expr->ref;
!
! for (; char_ref; char_ref = char_ref->next)
! if (char_ref->type == REF_SUBSTRING)
! {
! gfc_se tmp_se;
!
! expr->ts.cl = gfc_get_charlen ();
! expr->ts.cl->next = char_ref->u.ss.length->next;
! char_ref->u.ss.length->next = expr->ts.cl;
!
! gfc_init_se (&tmp_se, NULL);
! gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
! gfc_array_index_type);
! tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
! tmp_se.expr, gfc_index_one_node);
! tmp = gfc_evaluate_now (tmp, &parmse->pre);
! gfc_init_se (&tmp_se, NULL);
! gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
! gfc_array_index_type);
! tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
! tmp, tmp_se.expr);
! tmp = fold_convert (gfc_charlen_type_node, tmp);
! expr->ts.cl->backend_decl = tmp;
!
! break;
! }
! loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
! loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! }
loop.temp_ss->data.temp.dimen = loop.dimen;
loop.temp_ss->next = gfc_ss_terminator;
--- 1837,1847 ----
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
! loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! else
! loop.temp_ss->string_length = NULL;
+ parmse->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen;
loop.temp_ss->next = gfc_ss_terminator;
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2279,2286 ****
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
! if (e->expr_type == EXPR_VARIABLE
! && is_aliased_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
--- 2255,2261 ----
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
! if (e->expr_type == EXPR_VARIABLE && is_aliased_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 127610)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_trans_auto_array_allocation (tree de
*** 3927,3933 ****
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
! gfc_trans_init_string_length (sym->ts.cl, &block);
gfc_trans_vla_type_sizes (sym, &block);
--- 3927,3933 ----
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
! gfc_conv_string_length (sym->ts.cl, &block);
gfc_trans_vla_type_sizes (sym, &block);
*************** gfc_trans_auto_array_allocation (tree de
*** 3951,3957 ****
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
! gfc_trans_init_string_length (sym->ts.cl, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
--- 3951,3957 ----
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
! gfc_conv_string_length (sym->ts.cl, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
*************** gfc_trans_g77_array (gfc_symbol * sym, t
*** 4017,4023 ****
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
! gfc_trans_init_string_length (sym->ts.cl, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
--- 4017,4023 ----
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
! gfc_conv_string_length (sym->ts.cl, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
*************** gfc_trans_dummy_array_bias (gfc_symbol *
*** 4109,4115 ****
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
! gfc_trans_init_string_length (sym->ts.cl, &block);
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
--- 4109,4115 ----
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
! gfc_conv_string_length (sym->ts.cl, &block);
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4548,4610 ****
loop.temp_ss = gfc_get_ss ();
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
if (expr->ts.type == BT_CHARACTER)
! {
! if (expr->ts.cl == NULL)
! {
! /* This had better be a substring reference! */
! gfc_ref *char_ref = expr->ref;
! for (; char_ref; char_ref = char_ref->next)
! if (char_ref->type == REF_SUBSTRING)
! {
! mpz_t char_len;
! expr->ts.cl = gfc_get_charlen ();
! expr->ts.cl->next = char_ref->u.ss.length->next;
! char_ref->u.ss.length->next = expr->ts.cl;
!
! mpz_init_set_ui (char_len, 1);
! mpz_add (char_len, char_len,
! char_ref->u.ss.end->value.integer);
! mpz_sub (char_len, char_len,
! char_ref->u.ss.start->value.integer);
! expr->ts.cl->backend_decl
! = gfc_conv_mpz_to_tree (char_len,
! gfc_default_character_kind);
! /* Cast is necessary for *-charlen refs. */
! expr->ts.cl->backend_decl
! = convert (gfc_charlen_type_node,
! expr->ts.cl->backend_decl);
! mpz_clear (char_len);
! break;
! }
! gcc_assert (char_ref != NULL);
! loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
! loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! }
! else if (expr->ts.cl->length
! && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
! {
! gfc_conv_const_charlen (expr->ts.cl);
! loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
! loop.temp_ss->string_length
! = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
! }
! else
! {
! loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
! loop.temp_ss->string_length = expr->ts.cl->backend_decl;
! }
! se->string_length = loop.temp_ss->string_length;
! }
else
! {
! loop.temp_ss->data.temp.type
! = gfc_typenode_for_spec (&expr->ts);
! loop.temp_ss->string_length = NULL;
! }
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
--- 4548,4565 ----
loop.temp_ss = gfc_get_ss ();
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
+
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.cl, &se->pre);
+
+ loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
if (expr->ts.type == BT_CHARACTER)
! loop.temp_ss->string_length = expr->ts.cl->backend_decl;
else
! loop.temp_ss->string_length = NULL;
!
! se->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 5337,5343 ****
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
! gfc_trans_init_string_length (sym->ts.cl, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
--- 5292,5298 ----
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
! gfc_conv_string_length (sym->ts.cl, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 127610)
--- gcc/fortran/gfortran.h (working copy)
*************** try gfc_resolve_iterator (gfc_iterator *
*** 2268,2273 ****
--- 2268,2274 ----
try gfc_resolve_index (gfc_expr *, int);
try gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);
+ void gfc_resolve_substring_charlen (gfc_expr *);
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 127610)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_conv_string_tmp (gfc_se *, tree
*** 340,346 ****
/* Get the string length variable belonging to an expression. */
tree gfc_get_expr_charlen (gfc_expr *);
/* Initialize a string length variable. */
! void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
/* Ensure type sizes can be gimplified. */
void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
--- 340,346 ----
/* Get the string length variable belonging to an expression. */
tree gfc_get_expr_charlen (gfc_expr *);
/* Initialize a string length variable. */
! void gfc_conv_string_length (gfc_charlen *, stmtblock_t *);
/* Ensure type sizes can be gimplified. */
void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 127610)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_substring (gfc_ref *ref)
*** 3531,3536 ****
--- 3531,3598 ----
}
+ /* This function supplies missing substring charlens. */
+
+ void
+ gfc_resolve_substring_charlen (gfc_expr *e)
+ {
+ gfc_ref *char_ref = e->ref;
+ gfc_expr *start, *end;
+
+ for (; char_ref; char_ref = char_ref->next)
+ if (char_ref->type == REF_SUBSTRING)
+ break;
+
+ if (!char_ref)
+ return;
+
+ if (e->ts.cl)
+ {
+ if (e->ts.cl->length)
+ gfc_free_expr (e->ts.cl->length);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy)
+ return;
+ }
+
+ e->ts.type = BT_CHARACTER;
+ e->ts.kind = gfc_default_character_kind;
+
+ if (!e->ts.cl)
+ {
+ e->ts.cl = gfc_get_charlen ();
+ e->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = e->ts.cl;
+ }
+
+ if (char_ref->u.ss.start)
+ start = gfc_copy_expr (char_ref->u.ss.start);
+ else
+ start = gfc_int_expr (1);
+
+ if (char_ref->u.ss.end)
+ end = gfc_copy_expr (char_ref->u.ss.end);
+ else if (e->expr_type == EXPR_VARIABLE)
+ end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+ else
+ end = NULL;
+
+ if (!start || !end)
+ return;
+
+ /* Length = (end - start +1). */
+ e->ts.cl->length = gfc_subtract (end, start);
+ e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+
+ e->ts.cl->length->ts.type = BT_INTEGER;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+
+ /* Make sure that the length is simplified. */
+ gfc_simplify_expr (e->ts.cl->length, 0);
+ gfc_resolve_expr (e->ts.cl->length);
+ }
+
+
/* Resolve subtype references. */
static try
*************** check_host_association (gfc_expr *e)
*** 3904,3909 ****
--- 3966,4008 ----
}
+ static void
+ gfc_resolve_character_operator (gfc_expr *e)
+ {
+ gfc_expr *op1 = e->value.op.op1;
+ gfc_expr *op2 = e->value.op.op2;
+ gfc_expr *e1 = NULL;
+ gfc_expr *e2 = NULL;
+
+ gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+
+ if (op1->ts.cl && op1->ts.cl->length)
+ e1 = gfc_copy_expr (op1->ts.cl->length);
+ else if (op1->expr_type == EXPR_CONSTANT)
+ e1 = gfc_int_expr (op1->value.character.length);
+
+ if (op2->ts.cl && op2->ts.cl->length)
+ e2 = gfc_copy_expr (op2->ts.cl->length);
+ else if (op2->expr_type == EXPR_CONSTANT)
+ e2 = gfc_int_expr (op2->value.character.length);
+
+ e->ts.cl = gfc_get_charlen ();
+ e->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = e->ts.cl;
+
+ if (!e1 || !e2)
+ return;
+
+ e->ts.cl->length = gfc_add (e1, e2);
+ e->ts.cl->length->ts.type = BT_INTEGER;
+ e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+ gfc_simplify_expr (e->ts.cl->length, 0);
+ gfc_resolve_expr (e->ts.cl->length);
+
+ return;
+ }
+
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
*************** gfc_resolve_expr (gfc_expr *e)
*** 3933,3938 ****
--- 4032,4041 ----
if (t == SUCCESS)
expression_rank (e);
}
+
+ if (e->ts.type && e->ref && e->ref->type != REF_SUBSTRING)
+ gfc_resolve_substring_charlen (e);
+
break;
case EXPR_SUBSTRING:
*************** gfc_resolve_expr (gfc_expr *e)
*** 3981,3986 ****
--- 4084,4111 ----
gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
}
+ if (e->ts.type == BT_CHARACTER && !e->ts.cl)
+ {
+ /* The cases fall through so that changes in expression type
+ and the need for multiple fixes are picked up. */
+ switch (e->expr_type)
+ {
+ case EXPR_OP:
+ gfc_resolve_character_operator (e);
+
+ case EXPR_ARRAY:
+ if (e->expr_type == EXPR_ARRAY)
+ gfc_resolve_character_array_constructor (e);
+
+ case EXPR_SUBSTRING:
+ if (!e->ts.cl && e->ref)
+ gfc_resolve_substring_charlen (e);
+
+ default:
+ break;
+ }
+ }
+
return t;
}
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c (revision 127610)
--- gcc/fortran/iresolve.c (working copy)
*************** gfc_resolve_cshift (gfc_expr *f, gfc_exp
*** 548,553 ****
--- 548,556 ----
{
int n;
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
+
f->ts = array->ts;
f->rank = array->rank;
f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_eoshift (gfc_expr *f, gfc_ex
*** 668,673 ****
--- 671,679 ----
{
int n;
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
+
f->ts = array->ts;
f->rank = array->rank;
f->shape = gfc_copy_shape (array->shape, array->rank);
*************** gfc_resolve_merge (gfc_expr *f, gfc_expr
*** 1378,1383 ****
--- 1384,1395 ----
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
+ if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+ gfc_resolve_substring_charlen (tsource);
+
+ if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+ gfc_resolve_substring_charlen (fsource);
+
if (tsource->ts.type == BT_CHARACTER)
check_charlen_present (tsource);
*************** void
*** 1586,1591 ****
--- 1598,1606 ----
gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
gfc_expr *vector ATTRIBUTE_UNUSED)
{
+ if (array->ts.type == BT_CHARACTER && array->ref)
+ gfc_resolve_substring_charlen (array);
+
f->ts = array->ts;
f->rank = 1;
*************** gfc_resolve_reshape (gfc_expr *f, gfc_ex
*** 1689,1694 ****
--- 1704,1712 ----
int kind;
int i;
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
f->ts = source->ts;
gfc_array_size (shape, &rank);
*************** void
*** 1980,1985 ****
--- 1998,2006 ----
gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
gfc_expr *ncopies)
{
+ if (source->ts.type == BT_CHARACTER && source->ref)
+ gfc_resolve_substring_charlen (source);
+
if (source->ts.type == BT_CHARACTER)
check_charlen_present (source);
*************** gfc_resolve_transfer (gfc_expr *f, gfc_e
*** 2254,2259 ****
--- 2275,2284 ----
void
gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
{
+
+ if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+ gfc_resolve_substring_charlen (matrix);
+
f->ts = matrix->ts;
f->rank = 2;
if (matrix->shape)
*************** void
*** 2380,2385 ****
--- 2405,2413 ----
gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
gfc_expr *field ATTRIBUTE_UNUSED)
{
+ if (vector->ts.type == BT_CHARACTER && vector->ref)
+ gfc_resolve_substring_charlen (vector);
+
f->ts = vector->ts;
f->rank = mask->rank;
resolve_mask_arg (mask);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 127610)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_trans_dummy_character (gfc_symbol *s
*** 2420,2426 ****
gfc_start_block (&body);
/* Evaluate the string length expression. */
! gfc_trans_init_string_length (cl, &body);
gfc_trans_vla_type_sizes (sym, &body);
--- 2420,2426 ----
gfc_start_block (&body);
/* Evaluate the string length expression. */
! gfc_conv_string_length (cl, &body);
gfc_trans_vla_type_sizes (sym, &body);
*************** gfc_trans_auto_character_variable (gfc_s
*** 2444,2450 ****
gfc_start_block (&body);
/* Evaluate the string length expression. */
! gfc_trans_init_string_length (sym->ts.cl, &body);
gfc_trans_vla_type_sizes (sym, &body);
--- 2444,2450 ----
gfc_start_block (&body);
/* Evaluate the string length expression. */
! gfc_conv_string_length (sym->ts.cl, &body);
gfc_trans_vla_type_sizes (sym, &body);
Index: gcc/testsuite/gfortran.dg/char_length_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_7.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/char_length_7.f90 (revision 0)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ ! Test the fix for PR31879 in which the concatenation operators below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Vivek Rao <vivekrao4@yahoo.com>
+ !
+ module str_mod
+ character(3) :: mz(2) = (/"fgh","ijk"/)
+ contains
+ function ccopy(yy) result(xy)
+ character (len=*), intent(in) :: yy(:)
+ character (len=5) :: xy(size(yy))
+ xy = yy
+ end function ccopy
+ end module str_mod
+ !
+ program xx
+ use str_mod, only: ccopy, mz
+ implicit none
+ character(2) :: z = "zz"
+ character(3) :: zz(2) = (/"abc","cde"/)
+ character(2) :: ans(2)
+ integer :: i = 2, j = 3
+ if (any(ccopy("_&_"//(/"A","B"/)//"?") .ne. (/"_&_A?","_&_B?"/))) call abort ()
+ if (any(ccopy(z//zz) .ne. (/"zzabc","zzcde"/))) call abort ()
+ if (any(ccopy(z//zz(:)(1:2)) .ne. (/"zzab ","zzcd "/))) call abort ()
+ if (any(ccopy(z//mz(:)(2:3)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+
+ ! This was another bug, uncovered when the PR was fixed.
+ if (any(ccopy(z//mz(:)(i:j)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+ end program xx
+ ! { dg-final { cleanup-modules "str_mod" } }
Index: gcc/testsuite/gfortran.dg/char_assign_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_assign_1.f90 (revision 127610)
--- gcc/testsuite/gfortran.dg/char_assign_1.f90 (working copy)
*************** character(len=2), dimension(5) :: p
*** 11,17 ****
character(len=3), dimension(5) :: q
y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:)
if (p(1).ne."cd") call abort()
p(1) = y(1)%c ! { dg-warning "in assignment \\(2/5\\)" }
--- 11,17 ----
character(len=3), dimension(5) :: q
y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
! p(1) = y(1)%c(3:) ! { dg-warning "in assignment \\(2/3\\)" }
if (p(1).ne."cd") call abort()
p(1) = y(1)%c ! { dg-warning "in assignment \\(2/5\\)" }
Index: gcc/testsuite/gfortran.dg/char_length_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_length_8.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/char_length_8.f90 (revision 0)
***************
*** 0 ****
--- 1,69 ----
+ ! { dg-do run }
+ ! Test the fix for PR31197 and PR31258 in which the substrings below
+ ! would cause ICEs because the character lengths were never resolved.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ ! and Thomas Koenig <tkoenig@gcc.gnu.org>
+ !
+ CHARACTER(LEN=3), DIMENSION(10) :: Z
+ CHARACTER(LEN=3), DIMENSION(3,3) :: W
+ integer :: ctr = 0
+ call test_reshape
+ call test_eoshift
+ call test_cshift
+ call test_spread
+ call test_transpose
+ call test_pack
+ call test_unpack
+ call test_pr31197
+ if (ctr .ne. 8) call abort
+ contains
+ subroutine test_reshape
+ Z(:)="123"
+ if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_eoshift
+ CHARACTER(LEN=1), DIMENSION(10) :: chk
+ chk(1:8) = "5"
+ chk(9:10) = " "
+ Z(:)="456"
+ if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort
+ ctr = ctr + 1
+ END subroutine
+ subroutine test_cshift
+ Z(:)="901"
+ if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_spread
+ Z(:)="789"
+ if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_transpose
+ W(:, :)="abc"
+ if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_pack
+ W(:, :)="def"
+ if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_unpack
+ logical, dimension(5,2) :: mask
+ Z(:)="hij"
+ mask = .true.
+ if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) call abort
+ ctr = ctr + 1
+ end subroutine
+ subroutine test_pr31197
+ TYPE data
+ CHARACTER(LEN=3) :: A = "xyz"
+ END TYPE
+ TYPE(data), DIMENSION(10), TARGET :: T
+ if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) call abort
+ ctr = ctr + 1
+ end subroutine
+ END