From patchwork Sun Feb 6 09:59:29 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 82035 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 621C4B7043 for ; Sun, 6 Feb 2011 20:59:47 +1100 (EST) Received: (qmail 9504 invoked by alias); 6 Feb 2011 09:59:42 -0000 Received: (qmail 9484 invoked by uid 22791); 6 Feb 2011 09:59:40 -0000 X-SWARE-Spam-Status: No, hits=-2.1 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, TW_TM X-Spam-Check-By: sourceware.org Received: from mail-ey0-f175.google.com (HELO mail-ey0-f175.google.com) (209.85.215.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 06 Feb 2011 09:59:33 +0000 Received: by eya28 with SMTP id 28so1865586eya.20 for ; Sun, 06 Feb 2011 01:59:30 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.27.136 with SMTP id i8mr17625872ebc.11.1296986369977; Sun, 06 Feb 2011 01:59:29 -0800 (PST) Received: by 10.213.17.18 with HTTP; Sun, 6 Feb 2011 01:59:29 -0800 (PST) Date: Sun, 6 Feb 2011 10:59:29 +0100 Message-ID: Subject: [Patch, fortran] PR47592 - Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x', bar())) From: Paul Richard Thomas To: fortran@gcc.gnu.org, gcc-patches Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 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. 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 + ! + 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" } }