This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR47592 - Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x',bar()))
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 6 Feb 2011 10:59:29 +0100
- Subject: [Patch, fortran] PR47592 - Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x',bar()))
The fix for this PR is sufficiently straightforward that the patch and
the ChangeLogs speak for themselves.
Note that I have removed the calls of gfc_start_block and replaced
them with gfc_init_block, since the former does all sorts of strange
things with declarations as the warning in trans.c indicates.
Bootstraps and regtests on FC9/x86_64 - OK for trunk?
Cheers
Paul
2011-02-06 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
PR fortran/47592
* gfortran.dg/allocate_with_source_1 : New test.
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 169860)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4451,4464 ****
tree pstat;
tree error_label;
tree memsz;
stmtblock_t block;
if (!code->ext.alloc.list)
return NULL_TREE;
pstat = stat = error_label = tmp = memsz = NULL_TREE;
! gfc_start_block (&block);
/* Either STAT= and/or ERRMSG is present. */
if (code->expr1 || code->expr2)
--- 4451,4472 ----
tree pstat;
tree error_label;
tree memsz;
+ tree expr3;
+ tree slen3;
stmtblock_t block;
+ stmtblock_t post;
+ gfc_expr *sz;
+ gfc_se se_sz;
+ gfc_ref *ref;
+ bool allocatable;
if (!code->ext.alloc.list)
return NULL_TREE;
pstat = stat = error_label = tmp = memsz = NULL_TREE;
! gfc_init_block (&block);
! gfc_init_block (&post);
/* Either STAT= and/or ERRMSG is present. */
if (code->expr1 || code->expr2)
*************** gfc_trans_allocate (gfc_code * code)
*** 4472,4477 ****
--- 4480,4488 ----
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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4480,4486 ****
gfc_add_data_component (expr);
gfc_init_se (&se, NULL);
- gfc_start_block (&se.pre);
se.want_pointer = 1;
se.descriptor_only = 1;
--- 4491,4496 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4495,4502 ****
{
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);
--- 4505,4510 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4514,4520 ****
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,4527 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4522,4528 ****
gfc_conv_expr (&se_sz, code->expr3);
memsz = se_sz.string_length;
}
! else if (code->expr3->ts.u.cl
&& code->expr3->ts.u.cl->length)
{
gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
--- 4529,4536 ----
gfc_conv_expr (&se_sz, code->expr3);
memsz = se_sz.string_length;
}
! 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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4531,4550 ****
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;
}
}
else
--- 4539,4559 ----
gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.expr;
}
else
{
! /* 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
*************** gfc_trans_allocate (gfc_code * code)
*** 4580,4610 ****
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);
! }
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
se.expr,
--- 4589,4613 ----
TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz));
}
+
/* Allocate - for non-pointers with re-alloc checking. */
! 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);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
se.expr,
*************** gfc_trans_allocate (gfc_code * code)
*** 4629,4639 ****
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);
if (code->expr3 && !code->expr3->mold)
{
--- 4632,4640 ----
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
! gfc_add_block_to_block (&block, &se.pre);
if (code->expr3 && !code->expr3->mold)
{
*************** gfc_trans_allocate (gfc_code * code)
*** 4668,4673 ****
--- 4669,4681 ----
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
*************** gfc_trans_allocate (gfc_code * code)
*** 4799,4804 ****
--- 4807,4815 ----
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);
}
Index: gcc/testsuite/gfortran.dg/allocate_with_source_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/allocate_with_source_1.f90 (revision 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 <tkoenig@gcc.gnu.org>
+ !
+ 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" } }