From patchwork Wed Jun 13 08:00:27 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 164560 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 DDB70B7000 for ; Wed, 13 Jun 2012 18:01:07 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1340179268; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=LSbaZnf Mu48x9IbyRWi+nEdXGfY=; b=R25w1S7MWkHIHl8/X/fXSbGP5s/onu6UMMI70g/ AUMtoL9ZroVc3293JCzwPltp3C2qOFnMHf6rxPGx0OT+yfTIjQ/u1O2jUMW01NpI 0leLf2yP8PqFJ2KsTJBL5vrjlkpwCD81GeCuuC2zZa2NQWve2+apJ7mF2uzxq/YK uEu0= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=McInvK8XPLvWt+oLIqNCvAxHLfh391EIPUHkSDf8HdhzzWksVDlYprnRbg7ayp 3+6c7U2joikl78zcIC4hbZKKhNa+Wzle9GXoygm0WGGZ6r1/oW5DNFlMQj717Xe2 RxB7GMdIlCV7ymnfQUjDVRMafZszraxI4BP78IFmCM/zs=; Received: (qmail 2714 invoked by alias); 13 Jun 2012 08:01:01 -0000 Received: (qmail 2698 invoked by uid 22791); 13 Jun 2012 08:00:59 -0000 X-SWARE-Spam-Status: No, hits=2.6 required=5.0 tests=AWL, BAYES_00, KHOP_DNSBL_BUMP, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_BL, RCVD_IN_JMF_BL, TW_FC, TW_TM X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 13 Jun 2012 08:00:42 +0000 Received: from [192.168.178.22] (port-92-204-5-252.dynamic.qsc.de [92.204.5.252]) by mx02.qsc.de (Postfix) with ESMTP id 4106B28741; Wed, 13 Jun 2012 10:00:29 +0200 (CEST) Message-ID: <4FD8489B.5080906@net-b.de> Date: Wed, 13 Jun 2012 10:00:27 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:13.0) Gecko/20120601 Thunderbird/13.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR53642/45170c24 Deferred-length string fixes 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 This patch fixes issues with deferred length strings, where the new string length (= RHS len) is evaluated too late. That's fixed by calling gfc_add_block_to_block. I have no idea whether the condition makes sense or whether that function could always be called. Additionally, in the FE optimization, it avoids the removal of trim in "lhs = trim(rhs)" if the lhs has a deferred length. Build and regtested on x86-64-linux. OK for the trunk? Tobias 2012-06-13 Tobias Burnus PR fortran/53642 PR fortran/45170 * frontend-passes.c (optimize_assignment): Don't remove RHS's trim when assigning to a deferred-length string. * trans-expr.c (gfc_trans_assignment_1): Ensure that the RHS string length is evaluated before the deferred-length LHS is reallocated. 2012-06-13 Tobias Burnus PR fortran/53642 PR fortran/45170 * gfortran.dg/deferred_type_param_8.f90: New. diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index bcc1bdc..fc32e56 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -735,15 +735,13 @@ optimize_assignment (gfc_code * c) lhs = c->expr1; rhs = c->expr2; - if (lhs->ts.type == BT_CHARACTER) + if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) { - /* Optimize away a = trim(b), where a is a character variable. */ + /* Optimize a = trim(b) to a = b. */ remove_trim (rhs); - /* Replace a = ' ' by a = '' to optimize away a memcpy, but only - for strings with non-deferred length (otherwise we would - reallocate the length. */ - if (empty_string(rhs) && ! lhs->ts.deferred) + /* Replace a = ' ' by a = '' to optimize away a memcpy. */ + if (empty_string(rhs)) rhs->value.character.length = 0; } @@ -1171,7 +1169,7 @@ optimize_trim (gfc_expr *e) ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */ + /* Build the function call to len_trim(x, gfc_default_integer_kind). */ fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9d48a09..7d1a6d4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6891,7 +6891,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, stmtblock_t body; bool l_is_temp; bool scalar_to_array; - bool def_clen_func; tree string_length; int n; @@ -7010,13 +7009,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, otherwise the character length of the result is not known. NOTE: This relies on having the exact dependence of the length type parameter available to the caller; gfortran saves it in the .mod files. */ - def_clen_func = (expr2->expr_type == EXPR_FUNCTION - || expr2->expr_type == EXPR_COMPCALL - || expr2->expr_type == EXPR_PPC); - if (gfc_option.flag_realloc_lhs - && expr2->ts.type == BT_CHARACTER - && (def_clen_func || expr2->expr_type == EXPR_OP) - && expr1->ts.deferred) + if (gfc_option.flag_realloc_lhs && expr2->ts.type == BT_CHARACTER + && expr1->ts.deferred) gfc_add_block_to_block (&block, &rse.pre); tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, --- /dev/null 2012-06-12 08:13:11.079779038 +0200 +++ gcc/gcc/testsuite/gfortran.dg/deferred_type_param_8.f90 2012-06-13 09:30:31.000000000 +0200 @@ -0,0 +1,54 @@ +! { dg-do run } +! +! PR fortran/53642 +! PR fortran/45170 (comments 24, 34, 37) +! + +PROGRAM helloworld + implicit none + character(:),allocatable::string + character(11), parameter :: cmp = "hello world" + real::rnd + integer :: n, i + do i = 1, 10 + call random_number(rnd) + n = ceiling(11*rnd) + call hello(n, string) +! print '(A,1X,I0)', '>' // string // '<', len(string) + if (n /= len (string) .or. string /= cmp(1:n)) call abort () + end do + + call test_PR53642() + +contains + + subroutine hello (n,string) + character(:), allocatable, intent(out) :: string + integer,intent(in) :: n + character(11) :: helloworld="hello world" + + string=helloworld(:n) ! Didn't work +! string=(helloworld(:n)) ! Works. +! allocate(string, source=helloworld(:n)) ! Fixed for allocate_with_source_2.f90 +! allocate(string, source=(helloworld(:n))) ! Works. + end subroutine hello + + subroutine test_PR53642() + character(len=4) :: string="123 " + character(:), allocatable :: trimmed + + trimmed = trim(string) + if (len_trim(string) /= len(trimmed)) call abort () + if (len(trimmed) /= 3) call abort () + if (trimmed /= "123") call abort () +! print *,len_trim(string),len(trimmed) + + ! Clear + trimmed = "XXXXXX" + if (trimmed /= "XXXXXX" .or. len(trimmed) /= 6) call abort () + + trimmed = string(1:len_trim(string)) + if (len_trim(trimmed) /= 3) call abort () + if (trimmed /= "123") call abort () + end subroutine test_PR53642 +end PROGRAM helloworld