From patchwork Sun Dec 8 21:34: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: 298866 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.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 230B02C00A9 for ; Mon, 9 Dec 2013 08:35:11 +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:cc:subject:references :in-reply-to:content-type; q=dns; s=default; b=TVqpAbHmUuCpHf4Wr GVvrB0h7+vM6jZBvCOHIZZIfhItWSp0Z0sv5iJ/s1M9zRNt12RUzMGw7xdpKVz9t KYiw6UvF1pmjGwBV+bGFcRFQgz3vsj1ZNhiZ046HUWm3EvTEGBfHGsa6BgIujKzG 3VynIKzpLKNFn5MYjvbMy1msWg= 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:cc:subject:references :in-reply-to:content-type; s=default; bh=TPGs5LC49qCSmB+F9Wk/454 0yfY=; b=a+ezq+eJ++UZe5fSrJdZPfIxlAp7kvRWOROOFm7Bg5jpXedCcMA5D1/ ocHbLUL4iGdIl0PaqzHE4xfvkf7cE4gEdWqVTA/sWZ0B2K4V2V2cECMfFkPYzUN1 lIPSS3nsJCsjvfBGauwEAYlaIzE7XoVHK4W2bTpC8YF55a3/uuBY= Received: (qmail 30441 invoked by alias); 8 Dec 2013 21:34:58 -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 30406 invoked by uid 89); 8 Dec 2013 21:34:57 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 3 recipients X-HELO: mx01.qsc.de Received: from Unknown (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Sun, 08 Dec 2013 21:34:55 +0000 Received: from archimedes.net-b.de (port-92-194-51-180.dynamic.qsc.de [92.194.51.180]) by mx01.qsc.de (Postfix) with ESMTP id 41DDB44BCF; Sun, 8 Dec 2013 22:34:25 +0100 (CET) Message-ID: <52A4E5E1.30005@net-b.de> Date: Sun, 08 Dec 2013 22:34:25 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.1.0 MIME-Version: 1.0 To: Janus Weil CC: gcc patches , gfortran Subject: Re: [Patch, Fortran] PRs 59103/58676/41724 - honour pure-/elementalness of intrinsics, add elemental checks References: <52A482BD.9030008@net-b.de> In-Reply-To: Hi Janus, Janus Weil wrote: > first off: I assume the first PR number in the subject line is wrong, > since I don't see how it is related to your patch. I guess you meant > 58099? Yes. Well spotted. >> a) It ensures that sym->attr.pure/elemental gets set for pure/elemental >> intrinsics (isym->pure/elemental). > this part is ok with me (since it is exactly what I posted in PR 58099 > comment 18 ;) I have now added your name to the ChangeLog. >> b) It rejects dummy procedures / procedure pointers which are ELEMENTAL. > This also looks good (although it should maybe go into resolve_fl_procedure?). I had it elsewhere (I forgot where) and there I'd the problem that I got multiple times the same error. But at least with the current patch and looking manually at the output for elemental_subroutine_8.f90 it seems to work. Thanks for the suggestion. Tobias PS: I have now committed the attached patch as Rev. 205791. 2013-12-08 Tobias Burnus Janus Weil PR fortran/58099 PR fortran/58676 PR fortran/41724 * resolve.c (gfc_resolve_intrinsic): Set elemental/pure. (resolve_fl_procedure): Reject pure dummy procedures/procedure pointers. (gfc_explicit_interface_required): Don't require a match of ELEMENTAL for intrinsics. 2013-12-08 Tobias Burnus PR fortran/58099 PR fortran/58676 PR fortran/41724 * gfortran.dg/elemental_subroutine_8.f90: New. * gfortran.dg/proc_decl_9.f90: Add ELEMENTAL to make valid. * gfortran.dg/proc_ptr_11.f90: Ditto. * gfortran.dg/proc_ptr_result_8.f90: Ditto. * gfortran.dg/proc_ptr_32.f90: Update dg-error. * gfortran.dg/proc_ptr_33.f90: Ditto. * gfortran.dg/proc_ptr_result_1.f90: Add abstract interface which is not elemental. * gfortran.dg/proc_ptr_result_7.f90: Ditto. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5ed7053..ea46324 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1679,6 +1679,9 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) gfc_copy_formal_args_intr (sym, isym); + sym->attr.pure = isym->pure; + sym->attr.elemental = isym->elemental; + /* Check it is actually available in the standard settings. */ if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) { @@ -2314,7 +2317,7 @@ gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) } } - if (sym->attr.elemental) /* (4) */ + if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ { strncpy (errmsg, _("elemental procedure"), err_len); return true; @@ -11094,6 +11097,23 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) sym->name, &sym->declared_at); } + /* F2008, C1218. */ + if (sym->attr.elemental) + { + if (sym->attr.proc_pointer) + { + gfc_error ("Procedure pointer '%s' at %L shall not be elemental", + sym->name, &sym->declared_at); + return false; + } + if (sym->attr.dummy) + { + gfc_error ("Dummy procedure '%s' at %L shall not be elemental", + sym->name, &sym->declared_at); + return false; + } + } + if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) { gfc_formal_arglist *curr_arg; diff --git a/gcc/testsuite/gfortran.dg/proc_decl_9.f90 b/gcc/testsuite/gfortran.dg/proc_decl_9.f90 index 58ae321..455c27c 100644 --- a/gcc/testsuite/gfortran.dg/proc_decl_9.f90 +++ b/gcc/testsuite/gfortran.dg/proc_decl_9.f90 @@ -1,7 +1,7 @@ ! { dg-do run } ! PR33162 INTRINSIC functions as ACTUAL argument ! Test case adapted from PR by Jerry DeLisle -real function t(x) +elemental real function t(x) real, intent(in) ::x t = x end function @@ -9,6 +9,6 @@ end function program p implicit none intrinsic sin - procedure(sin):: t + procedure(sin) :: t if (t(1.0) /= 1.0) call abort end program diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 index bee73f4..61921e7 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 @@ -7,16 +7,23 @@ program bsp implicit none - + intrinsic :: isign, iabs abstract interface subroutine up() end subroutine up + ! As intrinsics but not elemental + pure integer function isign_interf(a, b) + integer, intent(in) :: a, b + end function isign_interf + pure integer function iabs_interf(x) + integer, intent(in) :: x + end function iabs_interf end interface procedure( up ) , pointer :: pptr - procedure(isign), pointer :: q + procedure(isign_interf), pointer :: q - procedure(iabs),pointer :: p1 + procedure(iabs_interf),pointer :: p1 procedure(f), pointer :: p2 pointer :: p3 @@ -48,13 +55,13 @@ program bsp contains - function add( a, b ) + pure function add( a, b ) integer :: add integer, intent( in ) :: a, b add = a + b end function add - integer function f(x) + pure integer function f(x) integer,intent(in) :: x f = 317 + x end function diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_32.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_32.f90 index 9cae65b..9b1ed58 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_32.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_32.f90 @@ -5,8 +5,8 @@ ! Contributed by James Van Buskirk implicit none - procedure(my_dcos), pointer :: f - f => my_dcos ! { dg-error "invalid in procedure pointer assignment" } + procedure(my_dcos), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" } + f => my_dcos ! { dg-error "Nonintrinsic elemental procedure 'my_dcos' is invalid in procedure pointer assignment" } contains real elemental function my_dcos(x) real, intent(in) :: x diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_33.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_33.f90 index 973162b..3001461 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_33.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_33.f90 @@ -22,7 +22,7 @@ end module program start use funcs implicit none - procedure(fun), pointer :: f + procedure(fun), pointer :: f ! { dg-error "Procedure pointer 'f' at .1. shall not be elemental" } real x(3) x = [1,2,3] f => my_dcos ! { dg-error "Mismatch in PURE attribute" } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 index a7ea218..4a8020e 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 @@ -171,7 +171,13 @@ contains end function function l() - procedure(iabs),pointer :: l + ! we cannot use iabs directly as it is elemental + abstract interface + pure function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs + end interface + procedure(interf_iabs),pointer :: l integer :: i l => iabs if (l(-11)/=11) call abort() diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_7.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_7.f90 index 1d810c6..b77e40b 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_7.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_7.f90 @@ -9,7 +9,14 @@ type :: t end type type(t) :: x -procedure(iabs), pointer :: pp + +! We cannot use "iabs" directly as it is elemental. +abstract interface + pure integer function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs +end interface +procedure(interf_iabs), pointer :: pp x%p => a @@ -20,7 +27,7 @@ if (pp(-3) /= 3) call abort contains function a() result (b) - procedure(iabs), pointer :: b + procedure(interf_iabs), pointer :: b b => iabs end function diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90 index 17812bc..be23f51 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90 @@ -26,7 +26,14 @@ type :: t end type type(t) :: x -procedure(iabs), pointer :: pp +! We cannot use iabs directly as it is elemental +abstract interface + integer pure function interf_iabs(x) + integer, intent(in) :: x + end function interf_iabs +end interface + +procedure(interf_iabs), pointer :: pp procedure(foo), pointer :: pp1 x%p => a ! ok @@ -47,7 +54,7 @@ contains function a (c) result (b) integer, intent(in) :: c - procedure(iabs), pointer :: b + procedure(interf_iabs), pointer :: b if (c .eq. 1) then b => iabs else @@ -55,7 +62,7 @@ contains end if end function - integer function foo (arg) + pure integer function foo (arg) integer, intent (in) :: arg foo = -iabs(arg) end function diff --git a/gcc/testsuite/gfortran.dg/elemental_subroutine_8.f90 b/gcc/testsuite/gfortran.dg/elemental_subroutine_8.f90 new file mode 100644 index 0000000..c557d3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_subroutine_8.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! PR fortran/58099 +! +! See also interpretation request F03-0130 in 09-217 and 10-006T5r1. +! +! - ELEMENTAL is only permitted for external names with PROCEDURE/INTERFACE +! but not for dummy arguments or proc-pointers +! - Using PROCEDURE with an elemental intrinsic as interface name a is valid, +! but doesn't make the proc-pointer/dummy argument elemental +! + + interface + elemental real function x(y) + real, intent(in) :: y + end function x + end interface + intrinsic :: sin + procedure(x) :: xx1 ! OK + procedure(x), pointer :: xx2 ! { dg-error "Procedure pointer 'xx2' at .1. shall not be elemental" } + procedure(real), pointer :: pp + procedure(sin) :: bar ! OK + procedure(sin), pointer :: foo ! { dg-error "Procedure pointer 'foo' at .1. shall not be elemental" } + pp => sin !OK +contains + subroutine sub1(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + procedure(x) :: z + end subroutine sub1 + subroutine sub2(z) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" } + procedure(x), pointer :: z + end subroutine sub2 + subroutine sub3(z) + interface + elemental real function z(y) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + real, intent(in) :: y + end function z + end interface + end subroutine sub3 + subroutine sub4(z) + interface + elemental real function z(y) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" } + real, intent(in) :: y + end function z + end interface + pointer :: z + end subroutine sub4 + subroutine sub5(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + procedure(sin) :: z + end subroutine sub5 +end