From ce082f77585fecdcf036414061fdda69e7ac8a9b Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 6 Feb 2011 14:22:48 +0000 Subject: [PATCH] 2011-02-06 Paul Thomas PR fortran/47592 * trans-stmt.c (gfc_trans_allocate): For deferred character length allocations with SOURCE, store to the values and string length to avoid calculating twice. Replace gfc_start_block with gfc_init_block to avoid unnecessary contexts and to keep declarations of temporaries where they should be. Tidy up the code a bit. 2011-02-06 Paul Thomas PR fortran/47592 * gfortran.dg/allocate_with_source_1 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@169862 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 +++ gcc/fortran/trans-stmt.c | 87 +++++++++++----------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/allocate_with_source_1.f90 | 29 ++++++++ 4 files changed, 86 insertions(+), 45 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b936715b36a..7fc66e0e60f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2011-02-06 Paul Thomas + + PR fortran/47592 + * trans-stmt.c (gfc_trans_allocate): For deferred character + length allocations with SOURCE, store to the values and string + length to avoid calculating twice. Replace gfc_start_block + with gfc_init_block to avoid unnecessary contexts and to keep + declarations of temporaries where they should be. Tidy up the + code a bit. + 2011-02-05 Janne Blomqvist PR fortran/42434 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2ac6989a2e6..6ddb2cab3ed 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4451,14 +4451,20 @@ gfc_trans_allocate (gfc_code * code) tree pstat; tree error_label; tree memsz; + tree expr3; + tree slen3; stmtblock_t block; + stmtblock_t post; + gfc_expr *sz; + gfc_se se_sz; if (!code->ext.alloc.list) return NULL_TREE; pstat = stat = error_label = tmp = memsz = NULL_TREE; - gfc_start_block (&block); + gfc_init_block (&block); + gfc_init_block (&post); /* Either STAT= and/or ERRMSG is present. */ if (code->expr1 || code->expr2) @@ -4472,6 +4478,9 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (error_label) = 1; } + expr3 = NULL_TREE; + slen3 = NULL_TREE; + for (al = code->ext.alloc.list; al != NULL; al = al->next) { expr = gfc_copy_expr (al->expr); @@ -4480,7 +4489,6 @@ gfc_trans_allocate (gfc_code * code) gfc_add_data_component (expr); gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); se.want_pointer = 1; se.descriptor_only = 1; @@ -4495,8 +4503,6 @@ gfc_trans_allocate (gfc_code * code) { if (code->expr3->ts.type == BT_CLASS) { - gfc_expr *sz; - gfc_se se_sz; sz = gfc_copy_expr (code->expr3); gfc_add_vptr_component (sz); gfc_add_size_component (sz); @@ -4514,7 +4520,6 @@ gfc_trans_allocate (gfc_code * code) if (!code->expr3->ts.u.cl->backend_decl) { /* Convert and use the length expression. */ - gfc_se se_sz; gfc_init_se (&se_sz, NULL); if (code->expr3->expr_type == EXPR_VARIABLE || code->expr3->expr_type == EXPR_CONSTANT) @@ -4522,7 +4527,8 @@ gfc_trans_allocate (gfc_code * code) gfc_conv_expr (&se_sz, code->expr3); memsz = se_sz.string_length; } - else if (code->expr3->ts.u.cl + else if (code->expr3->mold + && code->expr3->ts.u.cl && code->expr3->ts.u.cl->length) { gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length); @@ -4531,20 +4537,21 @@ gfc_trans_allocate (gfc_code * code) 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; - } 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; + /* This is would be inefficient and possibly could + generate wrong code if the result were not stored + in expr3/slen3. */ + if (slen3 == NULL_TREE) + { + gfc_conv_expr (&se_sz, code->expr3); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + expr3 = gfc_evaluate_now (se_sz.expr, &se.pre); + gfc_add_block_to_block (&post, &se_sz.post); + slen3 = gfc_evaluate_now (se_sz.string_length, + &se.pre); + } + memsz = slen3; } } else @@ -4580,31 +4587,13 @@ gfc_trans_allocate (gfc_code * code) TREE_TYPE (tmp), tmp, fold_convert (TREE_TYPE (tmp), memsz)); } + /* Allocate - for non-pointers with re-alloc checking. */ - { - gfc_ref *ref; - bool allocatable; - - ref = expr->ref; - - /* Find the last reference in the chain. */ - while (ref && ref->next != NULL) - { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); - ref = ref->next; - } - - if (!ref) - allocatable = expr->symtree->n.sym->attr.allocatable; - else - allocatable = ref->u.c.component->attr.allocatable; - - if (allocatable) - tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz, - pstat, expr); - else - tmp = gfc_allocate_with_status (&se.pre, memsz, pstat); - } + if (gfc_expr_attr (expr).allocatable) + tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz, + pstat, expr); + else + tmp = gfc_allocate_with_status (&se.pre, memsz, pstat); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, se.expr, @@ -4629,11 +4618,9 @@ gfc_trans_allocate (gfc_code * code) tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); gfc_add_expr_to_block (&se.pre, tmp); } - } - tmp = gfc_finish_block (&se.pre); - gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.pre); if (code->expr3 && !code->expr3->mold) { @@ -4668,6 +4655,13 @@ gfc_trans_allocate (gfc_code * code) gfc_add_block_to_block (&call.pre, &call.post); tmp = gfc_finish_block (&call.pre); } + else if (expr3 != NULL_TREE) + { + tmp = build_fold_indirect_ref_loc (input_location, se.expr); + gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind, + slen3, expr3, code->expr3->ts.kind); + tmp = NULL_TREE; + } else { /* Switch off automatic reallocation since we have just done @@ -4799,6 +4793,9 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } + gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &post); + return gfc_finish_block (&block); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 61110da51f2..7bb00576f21 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-02-06 Paul Thomas + + PR fortran/47592 + * gfortran.dg/allocate_with_source_1 : New test. + 2011-02-05 Jakub Jelinek PR middle-end/47610 diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 new file mode 100644 index 00000000000..d386bb33b7c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! Test the fix for PR47592, in which the SOURCE expression was +! being called twice. +! +! Contributed by Thomas Koenig +! +module foo + implicit none +contains + function bar() + integer bar + integer :: i=9 + i = i + 1 + bar = i + end function bar +end module foo + +program note7_35 + use foo + implicit none + character(:), allocatable :: name + character(:), allocatable :: src + integer n + n = 10 + allocate(name, SOURCE=repeat('x',bar())) + if (name .ne. 'xxxxxxxxxx') call abort + if (len (name) .ne. 10 ) call abort +end program note7_35 +! { dg-final { cleanup-modules "foo" } } -- 2.11.4.GIT