Commit fabb6f8e by Paul Thomas

re PR fortran/47519 (Deferred-length string wrong results with character intrinsic functions)

2011-01-31  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47519
	* trans-stmt.c (gfc_trans_allocate): Improve handling of
	deferred character lengths with SOURCE.
	* iresolve.c (gfc_resolve_repeat): Calculate character
	length from source length and ncopies.
	* dump-parse-tree.c (show_code_node): Show MOLD and SOURCE
	expressions for ALLOCATE.


2011-01-31  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47519
	* gfortran.dg/allocate_deferred_char_scalar_2.f03: New test.

From-SVN: r169444
parent b6c77bcb
2011-01-31 Paul Thomas <pault@gcc.gnu.org>
PR fortran/47519
* trans-stmt.c (gfc_trans_allocate): Improve handling of
deferred character lengths with SOURCE.
* iresolve.c (gfc_resolve_repeat): Calculate character
length from source length and ncopies.
* dump-parse-tree.c (show_code_node): Show MOLD and SOURCE
expressions for ALLOCATE.
2011-01-31 Janus Weil <janus@gcc.gnu.org> 2011-01-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/47463 PR fortran/47463
......
...@@ -1605,6 +1605,15 @@ show_code_node (int level, gfc_code *c) ...@@ -1605,6 +1605,15 @@ show_code_node (int level, gfc_code *c)
show_expr (c->expr2); show_expr (c->expr2);
} }
if (c->expr3)
{
if (c->expr3->mold)
fputs (" MOLD=", dumpfile);
else
fputs (" SOURCE=", dumpfile);
show_expr (c->expr3);
}
for (a = c->ext.alloc.list; a; a = a->next) for (a = c->ext.alloc.list; a; a = a->next)
{ {
fputc (' ', dumpfile); fputc (' ', dumpfile);
......
...@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see ...@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h" #include "gfortran.h"
#include "intrinsic.h" #include "intrinsic.h"
#include "constructor.h" #include "constructor.h"
#include "arith.h"
/* Given printf-like arguments, return a stable version of the result string. /* Given printf-like arguments, return a stable version of the result string.
...@@ -2044,11 +2045,31 @@ gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, ...@@ -2044,11 +2045,31 @@ gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
void void
gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
gfc_expr *ncopies ATTRIBUTE_UNUSED) gfc_expr *ncopies)
{ {
int len;
gfc_expr *tmp;
f->ts.type = BT_CHARACTER; f->ts.type = BT_CHARACTER;
f->ts.kind = string->ts.kind; f->ts.kind = string->ts.kind;
f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
/* If possible, generate a character length. */
if (f->ts.u.cl == NULL)
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
tmp = NULL;
if (string->expr_type == EXPR_CONSTANT)
{
len = string->value.character.length;
tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
}
else if (string->ts.u.cl && string->ts.u.cl->length)
{
tmp = gfc_copy_expr (string->ts.u.cl->length);
}
if (tmp)
f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
} }
......
...@@ -4522,15 +4522,30 @@ gfc_trans_allocate (gfc_code * code) ...@@ -4522,15 +4522,30 @@ gfc_trans_allocate (gfc_code * code)
gfc_conv_expr (&se_sz, code->expr3); gfc_conv_expr (&se_sz, code->expr3);
memsz = se_sz.string_length; memsz = se_sz.string_length;
} }
else else if (code->expr3->ts.u.cl
&& code->expr3->ts.u.cl->length)
{
gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
gfc_add_block_to_block (&se.pre, &se_sz.pre);
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.expr;
}
else if (code->ext.alloc.ts.u.cl
&& code->ext.alloc.ts.u.cl->length)
{ {
gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
memsz = se_sz.expr; memsz = se_sz.expr;
} }
if (TREE_CODE (se.string_length) == VAR_DECL) else
gfc_add_modify (&block, se.string_length, {
fold_convert (TREE_TYPE (se.string_length), /* This is likely to be inefficient. */
memsz)); gfc_conv_expr (&se_sz, code->expr3);
gfc_add_block_to_block (&se.pre, &se_sz.pre);
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.string_length;
}
} }
else else
/* Otherwise use the stored string length. */ /* Otherwise use the stored string length. */
...@@ -4539,7 +4554,7 @@ gfc_trans_allocate (gfc_code * code) ...@@ -4539,7 +4554,7 @@ gfc_trans_allocate (gfc_code * code)
/* Store the string length. */ /* Store the string length. */
if (tmp && TREE_CODE (tmp) == VAR_DECL) if (tmp && TREE_CODE (tmp) == VAR_DECL)
gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
memsz)); memsz));
/* Convert to size in bytes, using the character KIND. */ /* Convert to size in bytes, using the character KIND. */
...@@ -4556,18 +4571,8 @@ gfc_trans_allocate (gfc_code * code) ...@@ -4556,18 +4571,8 @@ gfc_trans_allocate (gfc_code * code)
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
{ {
if (expr->ts.deferred) memsz = se.string_length;
{
gfc_se se_sz;
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
memsz = se_sz.expr;
gfc_add_modify (&block, se.string_length,
fold_convert (TREE_TYPE (se.string_length),
memsz));
}
else
memsz = se.string_length;
/* Convert to size in bytes, using the character KIND. */ /* Convert to size in bytes, using the character KIND. */
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
tmp = TYPE_SIZE_UNIT (tmp); tmp = TYPE_SIZE_UNIT (tmp);
...@@ -4664,8 +4669,15 @@ gfc_trans_allocate (gfc_code * code) ...@@ -4664,8 +4669,15 @@ gfc_trans_allocate (gfc_code * code)
tmp = gfc_finish_block (&call.pre); tmp = gfc_finish_block (&call.pre);
} }
else else
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), {
rhs, false, false); /* Switch off automatic reallocation since we have just done
the ALLOCATE. */
int realloc_lhs = gfc_option.flag_realloc_lhs;
gfc_option.flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
rhs, false, false);
gfc_option.flag_realloc_lhs = realloc_lhs;
}
gfc_free_expr (rhs); gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
......
2011-01-31 Paul Thomas <pault@gcc.gnu.org>
PR fortran/47519
* gfortran.dg/allocate_deferred_char_scalar_2.f03: New test.
2011-01-31 Janus Weil <janus@gcc.gnu.org> 2011-01-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/47463 PR fortran/47463
......
! { dg-do run }
! Test the fix for PR47519, in which the character length was not
! calculated for the SOURCE expressions below and an ICE resulted.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
program note7_35
implicit none
character(:), allocatable :: name
character(:), allocatable :: src
integer n
n = 10
allocate(name, SOURCE=repeat('x',n))
if (name .ne. 'xxxxxxxxxx') call abort
if (len (name) .ne. 10 ) call abort
deallocate(name)
src = 'xyxy'
allocate(name, SOURCE=repeat(src,n))
if (name(37:40) .ne. 'xyxy') call abort
if (len (name) .ne. 40 ) call abort
end program note7_35
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment