From 4ac968e7dd021116ee8f81f9a2063a32f6a2c61a Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 31 Jan 2011 19:13:13 +0000 Subject: [PATCH] 2011-01-31 Paul Thomas 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 PR fortran/47519 * gfortran.dg/allocate_deferred_char_scalar_2.f03: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@169444 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 ++++ gcc/fortran/dump-parse-tree.c | 9 ++++ gcc/fortran/iresolve.c | 23 +++++++- gcc/fortran/trans-stmt.c | 52 ++++++++++++------- gcc/testsuite/ChangeLog | 5 ++ .../allocate_deferred_char_scalar_2.f03 | 21 ++++++++ 6 files changed, 99 insertions(+), 21 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e146d761004f..ae08fdc6a879 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2011-01-31 Paul Thomas + + 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 PR fortran/47463 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 24e9ea5d1d58..424feb1e68e6 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1605,6 +1605,15 @@ show_code_node (int level, gfc_code *c) 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) { fputc (' ', dumpfile); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index ec9dd422fb62..d8309d27f857 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "intrinsic.h" #include "constructor.h" +#include "arith.h" /* 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, void 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.kind = 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)); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 161b309e00fd..2ac6989a2e66 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4522,15 +4522,30 @@ gfc_trans_allocate (gfc_code * code) gfc_conv_expr (&se_sz, code->expr3); 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); memsz = se_sz.expr; } - if (TREE_CODE (se.string_length) == VAR_DECL) - gfc_add_modify (&block, se.string_length, - fold_convert (TREE_TYPE (se.string_length), - memsz)); + else + { + /* This is likely to be inefficient. */ + 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 /* Otherwise use the stored string length. */ @@ -4539,7 +4554,7 @@ gfc_trans_allocate (gfc_code * code) /* Store the string length. */ 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)); /* Convert to size in bytes, using the character KIND. */ @@ -4556,18 +4571,8 @@ gfc_trans_allocate (gfc_code * code) if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) { - if (expr->ts.deferred) - { - 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; + memsz = se.string_length; + /* Convert to size in bytes, using the character KIND. */ tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts)); tmp = TYPE_SIZE_UNIT (tmp); @@ -4664,8 +4669,15 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_finish_block (&call.pre); } 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_add_expr_to_block (&block, tmp); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0c17d83d189d..824f3ca5cf8d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-31 Paul Thomas + + PR fortran/47519 + * gfortran.dg/allocate_deferred_char_scalar_2.f03: New test. + 2011-01-31 Janus Weil PR fortran/47463 diff --git a/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03 b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03 new file mode 100644 index 000000000000..1f0f43301051 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03 @@ -0,0 +1,21 @@ +! { 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 +! +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 -- 2.47.2