From patchwork Thu Mar 21 18:02:21 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 229789 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 491802C00A3 for ; Fri, 22 Mar 2013 05:02:44 +1100 (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=YKN67OxyNLA2EfRkpi0AbJbHFzoxF6QvDTBKWZGsIvDmBs OmU+tfsOJy7NHF1US7P2rfABT0gDTfOLPSeKs8TeIVVU9LnXtQKOdWlg9Ta8SLhP RC0Gz2+nb4MFBVnr1vkN1FLNIPz57OVOKbn11SKyvoDcJaG1rfdm1gMSJg+Fk= 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=WB7jVtJ6m/5w746fBRsmlxUAKE0=; b=wAzXQ1DKCMBiwM77ZDeo L//VbEocrYoIcU0M8o35SpVqDlsvfzMnBRreECBQwvq44VxhaTXXQR00jWJOGb3v eOmjAXC15ENJfvCeGlf8wOldtpoWOPWv0nd4hTvg9PmPwPauPB7x7olKDS+GNcP0 xytXEb/6lUZ3mYFyZUMmdB4= Received: (qmail 1531 invoked by alias); 21 Mar 2013 18:02:38 -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 1470 invoked by uid 89); 21 Mar 2013 18:02:29 -0000 X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_CP, TW_PL autolearn=no 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, 21 Mar 2013 18:02:25 +0000 Received: from archimedes.net-b.de (port-92-195-211-180.dynamic.qsc.de [92.195.211.180]) by mx01.qsc.de (Postfix) with ESMTP id 853F33CEBE; Thu, 21 Mar 2013 19:02:21 +0100 (CET) Message-ID: <514B4B2D.20201@net-b.de> Date: Thu, 21 Mar 2013 19:02:21 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130307 Thunderbird/17.0.4 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR35203 - Fix VALUE + OPTIONAL handling for pass-by-value arguments Dear all, using VALUE, gfortran passes the arguments by value.* That works well, except if VALUE is combined with OPTIONAL. Currently, "call foo(0)" and "call foo()" are indistinguishable. With this patch, a hidden argument is added which includes the present information. I think that's the least intrusive version which also has the performance advantage of continuing to use pass-by-value semantics. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias PS: At some point, we need to handle VALUE with arrays, derived types and class. For those, one should pass by reference, doing a copy in. In that case, using the NULL-pointer check for present() should work. (PR 49802) * Except for character. (Note: value+optional for characters currently fails with an ICE, also tracked at PR 49802.) 2013-03-21 Tobias Burnus PR fortran/35203 * trans-decl.c (create_function_arglist): Pass hidden argument for passed-by-value optional+value dummies. * trans-expr.c (gfc_conv_expr_present, gfc_conv_procedure_call): Handle those. 2013-03-21 Tobias Burnus PR fortran/35203 * gfortran.dg/optional_absent_3.f90: New. diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 0e853ba..fafde89 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2142,6 +2142,27 @@ create_function_arglist (gfc_symbol * sym) type = gfc_sym_type (f->sym); } } + /* For noncharacter scalar intrinsic types, VALUE passes the value, + hence, the optional status cannot be transfered via a NULL pointer. + Thus, we will use a hidden argument in that case. */ + else if (f->sym->attr.optional && f->sym->attr.value + && !f->sym->attr.dimension && !f->sym->ts.type != BT_CLASS + && f->sym->ts.type != BT_DERIVED) + { + tree tmp; + strcpy (&name[1], f->sym->name); + name[0] = '_'; + tmp = build_decl (input_location, + PARM_DECL, get_identifier (name), + boolean_type_node); + + hidden_arglist = chainon (hidden_arglist, tmp); + DECL_CONTEXT (tmp) = fndecl; + DECL_ARTIFICIAL (tmp) = 1; + DECL_ARG_TYPE (tmp) = boolean_type_node; + TREE_READONLY (tmp) = 1; + gfc_finish_decl (tmp); + } /* For non-constant length array arguments, make sure they use a different type node from TYPE_ARG_TYPES type. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2c3ff1f..34e1ef0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1126,8 +1126,32 @@ gfc_conv_expr_present (gfc_symbol * sym) tree decl, cond; gcc_assert (sym->attr.dummy); - decl = gfc_get_symbol_decl (sym); + + /* Intrinsic scalars with VALUE attribute which are passed by value + use a hidden argument to denote the present status. */ + if (sym->attr.value && sym->ts.type != BT_CHARACTER + && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED + && !sym->attr.dimension) + { + char name[GFC_MAX_SYMBOL_LEN + 2]; + tree tree_name; + + gcc_assert (TREE_CODE (decl) == PARM_DECL); + name[0] = '_'; + strcpy (&name[1], sym->name); + tree_name = get_identifier (name); + + /* Walk function argument list to find hidden arg. */ + cond = DECL_ARGUMENTS (DECL_CONTEXT (decl)); + for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond)) + if (DECL_NAME (cond) == tree_name) + break; + + gcc_assert (cond); + return cond; + } + if (TREE_CODE (decl) != PARM_DECL) { /* Array parameters use a temporary descriptor, we want the real @@ -4052,11 +4076,27 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - /* Pass a NULL pointer for an absent arg. */ gfc_init_se (&parmse, NULL); - parmse.expr = null_pointer_node; - if (arg->missing_arg_type == BT_CHARACTER) - parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); + + /* For scalar arguments with VALUE attribute which are passed by + value, pass "0" and a hidden argument gives the optional + status. */ + if (fsym && fsym->attr.optional && fsym->attr.value + && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER + && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED) + { + parmse.expr = fold_convert (gfc_sym_type (fsym), + integer_zero_node); + vec_safe_push (stringargs, boolean_false_node); + } + else + { + /* Pass a NULL pointer for an absent arg. */ + parmse.expr = null_pointer_node; + if (arg->missing_arg_type == BT_CHARACTER) + parmse.string_length = build_int_cst (gfc_charlen_type_node, + 0); + } } } else if (arg->expr->expr_type == EXPR_NULL @@ -4227,7 +4267,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, e); } else + { gfc_conv_expr (&parmse, e); + if (fsym->attr.optional + && fsym->ts.type != BT_CLASS + && fsym->ts.type != BT_DERIVED) + { + if (e->expr_type != EXPR_VARIABLE + || !e->symtree->n.sym->attr.optional + || e->ref != NULL) + vec_safe_push (stringargs, boolean_true_node); + else + { + tmp = gfc_conv_expr_present (e->symtree->n.sym); + if (!e->symtree->n.sym->attr.value) + parmse.expr + = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (parmse.expr), + tmp, parmse.expr, + fold_convert (TREE_TYPE (parmse.expr), + integer_zero_node)); + + vec_safe_push (stringargs, tmp); + } + } + } } else if (arg->name && arg->name[0] == '%') /* Argument list functions %VAL, %LOC and %REF are signalled diff --git a/gcc/testsuite/gfortran.dg/optional_absent_3.f90 b/gcc/testsuite/gfortran.dg/optional_absent_3.f90 new file mode 100644 index 0000000..f03b479 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_3.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! +! PR fortran/35203 +! +! Test VALUE + OPTIONAL +! for integer/real/complex/logical which are passed by value +! +program main + implicit none + call value_test () +contains + subroutine value_test (ii, rr, cc, ll, ii2, rr2, cc2, ll2) + integer, optional :: ii, ii2 + real, optional :: rr, rr2 + complex, optional :: cc, cc2 + logical, optional :: ll, ll2 + value :: ii, rr, cc, ll + + call int_test (.false., 0) + call int_test (.false., 0, ii) + call int_test (.false., 0, ii2) + call int_test (.true., 0, 0) + call int_test (.true., 2, 2) + + call real_test (.false., 0.0) + call real_test (.false., 0.0, rr) + call real_test (.false., 0.0, rr2) + call real_test (.true., 0.0, 0.0) + call real_test (.true., 2.0, 2.0) + + call cmplx_test (.false., cmplx (0.0)) + call cmplx_test (.false., cmplx (0.0), cc) + call cmplx_test (.false., cmplx (0.0), cc2) + call cmplx_test (.true., cmplx (0.0), cmplx (0.0)) + call cmplx_test (.true., cmplx (2.0), cmplx (2.0)) + + call bool_test (.false., .false.) + call bool_test (.false., .false., ll) + call bool_test (.false., .false., ll2) + call bool_test (.true., .false., .false.) + call bool_test (.true., .true., .true.) + end subroutine value_test + + subroutine int_test (ll, val, x) + logical, value :: ll + integer, value :: val + integer, value, optional :: x + if (ll .neqv. present(x)) call abort + if (present(x)) then + if (x /= val) call abort () + endif + end subroutine int_test + + subroutine real_test (ll, val, x) + logical, value :: ll + real, value :: val + real, value, optional :: x + if (ll .neqv. present(x)) call abort + if (present(x)) then + if (x /= val) call abort () + endif + end subroutine real_test + + subroutine cmplx_test (ll, val, x) + logical, value :: ll + complex, value :: val + complex, value, optional :: x + if (ll .neqv. present(x)) call abort + if (present(x)) then + if (x /= val) call abort () + endif + end subroutine cmplx_test + + subroutine bool_test (ll, val, x) + logical, value :: ll + logical, value :: val + logical, value, optional :: x + if (ll .neqv. present(x)) call abort + if (present(x)) then + if (x .neqv. val) call abort () + endif + end subroutine bool_test +end program main