From patchwork Thu Jun 13 09:13:25 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 251018 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id EF3802C009D for ; Thu, 13 Jun 2013 19:13:43 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=ZAcV+JZTalt+tPryiU/DNNawSFOgCVUukPbUntlVkD2lJk hqZ0f6kyQJWddlKSRqSO4Lw42gI2lYw4m+jdwGXVkcbyfnaaxso1lF4aM4hJBucA 5noQJqA59OSRZU+NZ1XM/SWxXMT96QHd8g32fQPyxcBpITPwkU7ParmGujmXg= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=gUq6dHGA4j++sj1nUI5NXHzC6xA=; b=XEZUdiQrg76O8o8gRLwZ kqHX/X7HQ/11s5QFc3+ZRlF9gzlnA0X4XYk4r0U3Z70IY83XdbvdMx7zBjCskH23 vBl2hQ5BvSvIDd6cjmHZEGRoG9IqBvO2DKbio5AybjL6xuWOPsOqeKJXPh68MqSO 09vV7d4VJmim8QyXFjGjLHc= Received: (qmail 26106 invoked by alias); 13 Jun 2013 09:13:31 -0000 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 Received: (qmail 26089 invoked by uid 89); 13 Jun 2013 09:13:31 -0000 X-Spam-SWARE-Status: No, score=-2.2 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 13 Jun 2013 09:13:29 +0000 Received: from archimedes.net-b.de (port-92-195-31-211.dynamic.qsc.de [92.195.31.211]) by mx01.qsc.de (Postfix) with ESMTP id E048C3CF77; Thu, 13 Jun 2013 11:13:26 +0200 (CEST) Message-ID: <51B98D35.8060800@net-b.de> Date: Thu, 13 Jun 2013 11:13:25 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130510 Thunderbird/17.0.6 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR57596 - Fix OPTIONAL handling of deferred-length strings X-Virus-Found: No A rather simple patch. I wonder why we didn't get in trouble before - the "*dummy = NULL;" part should affect also other optional allocatable dummy arguments. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: Pending patches: * Unreviewed: Print exception status at STOP, http://gcc.gnu.org/ml/fortran/2013-06/msg00077.html * Uncommitted: Mikael's CLASS+function patch, http://gcc.gnu.org/ml/fortran/2013-06/msg00079.html PPS: The old dump (GCC 4.8, 4.9 w/o patch should be the same) produced: get (character(kind=1)[1:(integer(kind=4)) _c_val] * * c_val, integer(kind=4) * _c_val) { *c_val = 0B; ... finally { *_c_val = .c_val; } } and with intent(inout): .c_val = *_c_val; 2013-06-13 Tobias Burnus PR fortran/57596 * trans-decl.c (gfc_trans_deferred_vars): Honor OPTIONAL for nullify and deferred-strings' length variable. 2013-06-13 Tobias Burnus PR fortran/57596 * gfortran.dg/deferred_type_param_9.f90: New. diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 87652ba..300175f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3855,12 +3857,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) { /* Nullify when entering the scope. */ - gfc_add_modify (&init, se.expr, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (se.expr), se.expr, + fold_convert (TREE_TYPE (se.expr), + null_pointer_node)); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&init, tmp); } - if ((sym->attr.dummy ||sym->attr.result) + if ((sym->attr.dummy || sym->attr.result) && sym->ts.type == BT_CHARACTER && sym->ts.deferred) { @@ -3874,15 +3885,38 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_modify (&init, sym->ts.u.cl->backend_decl, build_int_cst (gfc_charlen_type_node, 0)); else - gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp); + { + tree tmp2; + + tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, + gfc_charlen_type_node, + sym->ts.u.cl->backend_decl, tmp); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp2 = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp2, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&init, tmp2); + } gfc_restore_backend_locus (&loc); /* Pass the final character length back. */ if (sym->attr.intent != INTENT_IN) - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - gfc_charlen_type_node, tmp, - sym->ts.u.cl->backend_decl); + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + gfc_charlen_type_node, tmp, + sym->ts.u.cl->backend_decl); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } + } else tmp = NULL_TREE; } --- /dev/null 2013-06-13 09:10:45.615178715 +0200 +++ gcc/gcc/testsuite/gfortran.dg/deferred_type_param_9.f90 2013-06-13 10:55:51.506836678 +0200 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/57596 +! +! Contributed by Valery Weber +! +PROGRAM main + IMPLICIT NONE + call get () + call get2 () +contains + SUBROUTINE get (c_val) + CHARACTER( : ), INTENT( INOUT ), ALLOCATABLE, OPTIONAL :: c_val + CHARACTER( 10 ) :: c_val_tmp + if(present(c_val)) call abort() + END SUBROUTINE get + SUBROUTINE get2 (c_val) + CHARACTER( : ), INTENT( OUT ), ALLOCATABLE, OPTIONAL :: c_val + CHARACTER( 10 ) :: c_val_tmp + if(present(c_val)) call abort() + END SUBROUTINE get2 +END PROGRAM main