From patchwork Fri Dec 19 22:53:26 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 423008 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)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id A7013140079 for ; Sat, 20 Dec 2014 09:53:39 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:date:message-id:subject:from:to:content-type; q= dns; s=default; b=hYRbZfsZcNuL7y5DmF4DxZpst7nNianpYnWSKEH8hp9XaZ Pf1xJPI3RTTmmLthLKRuok7LJjnHdl5AL8Krkp2ILQRayOBgMgbxDDSJCzsDyRLj jVC3Y+n6VPp2wF5/zxINpY+JwB7E7yjXgGjJ80Zn0dZf8pElWtwtK+4HZJmPw= 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 :mime-version:date:message-id:subject:from:to:content-type; s= default; bh=PAzPzKsY8+lb/cMDTYsjT96gk1A=; b=edew7sTL2QicM/F8N6+9 16X2AQzI25UaFa1U13VZ/yu0Sw4opJRu4XoaQyU7k7UNlo8aJUpVrThVO4Mvapna tdVgRIYELAvCs68uoFEfjIsQrJSD6ziJq7mKypnVEZCqCwc1B7GnJVENec3PKUmk WzKHTDaJd2zQGFgKyvvDp0M= Received: (qmail 11337 invoked by alias); 19 Dec 2014 22:53:32 -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 11314 invoked by uid 89); 19 Dec 2014 22:53:31 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-qc0-f171.google.com Received: from mail-qc0-f171.google.com (HELO mail-qc0-f171.google.com) (209.85.216.171) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Fri, 19 Dec 2014 22:53:28 +0000 Received: by mail-qc0-f171.google.com with SMTP id r5so1353475qcx.16; Fri, 19 Dec 2014 14:53:26 -0800 (PST) MIME-Version: 1.0 X-Received: by 10.224.7.69 with SMTP id c5mr18050159qac.71.1419029606342; Fri, 19 Dec 2014 14:53:26 -0800 (PST) Received: by 10.96.211.7 with HTTP; Fri, 19 Dec 2014 14:53:26 -0800 (PST) Date: Fri, 19 Dec 2014 23:53:26 +0100 Message-ID: Subject: [Patch, Fortran, F08] PR 54756: Should reject CLASS, intent(out) in PURE procedures From: Janus Weil To: gfortran , gcc-patches Hi all, after committing my recent patch for PR 64209, I realized that the accompanying test case is actually invalid in one aspect and that there is already a PR (and patch) for that problem: PR 54756. It's about F08 forbidding polymorphic INTENT(OUT) arguments in pure procedures. The reason for this restriction is essentially that a finalizer (if present) would need to be called for such an argument, and the finalizer could be impure (which in general can not be checked at compile time). The constraint technically only exists in F08 and not in F03, but my patch unconditionally rejects such code. In fact the patch uncovered a good number of cases in the testsuite, which are invalid in this respect. I fixed all of them by making the encompassing procedure impure. After that the patch regtests cleanly. Ok for trunk? Cheers, Janus 2014-12-19 Janus Weil PR fortran/54756 * resolve.c (resolve_formal_arglist): Reject polymorphic INTENT(OUT) arguments of pure procedures. 2014-12-19 Janus Weil PR fortran/54756 * gfortran.dg/class_array_3.f03: Fixed invalid test case. * gfortran.dg/class_array_7.f03: Ditto. * gfortran.dg/class_dummy_4.f03: Ditto. * gfortran.dg/defined_assignment_3.f90: Ditto. * gfortran.dg/defined_assignment_5.f90: Ditto. * gfortran.dg/elemental_subroutine_10.f90: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_16.f03: Ditto. * gfortran.dg/unlimited_polymorphic_19.f90: Ditto. * gfortran.dg/class_dummy_5.f90: New test. Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 218978) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -414,6 +414,15 @@ resolve_formal_arglist (gfc_symbol *proc) &sym->declared_at); } } + + /* F08:C1278a. */ + if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) + { + gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L" + " may not be polymorphic", sym->name, proc->name, + &sym->declared_at); + continue; + } } if (proc->attr.implicit_pure) Index: gcc/testsuite/gfortran.dg/class_array_3.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_array_3.f03 (Revision 218978) +++ gcc/testsuite/gfortran.dg/class_array_3.f03 (Arbeitskopie) @@ -29,7 +29,7 @@ module m_qsort end function lt_cmp end interface interface - elemental subroutine assign(a,b) + impure elemental subroutine assign(a,b) import class(sort_t), intent(out) :: a class(sort_t), intent(in) :: b @@ -100,7 +100,7 @@ contains class(sort_int_t), intent(in) :: a disp_int = a%i end function disp_int - elemental subroutine assign_int (a, b) + impure elemental subroutine assign_int (a, b) class(sort_int_t), intent(out) :: a class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)' select type (b) Index: gcc/testsuite/gfortran.dg/class_array_7.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_array_7.f03 (Revision 218978) +++ gcc/testsuite/gfortran.dg/class_array_7.f03 (Arbeitskopie) @@ -19,7 +19,7 @@ module realloc contains - elemental subroutine assign (a, b) + impure elemental subroutine assign (a, b) class(base_type), intent(out) :: a type(base_type), intent(in) :: b a%i = b%i Index: gcc/testsuite/gfortran.dg/class_dummy_4.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_dummy_4.f03 (Revision 218978) +++ gcc/testsuite/gfortran.dg/class_dummy_4.f03 (Arbeitskopie) @@ -11,7 +11,7 @@ module m1 procedure, pass(x) :: source end type c_stv contains - pure subroutine source(y,x) + subroutine source(y,x) class(c_stv), intent(in) :: x class(c_stv), allocatable, intent(out) :: y end subroutine source Index: gcc/testsuite/gfortran.dg/defined_assignment_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (Revision 218978) +++ gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (Arbeitskopie) @@ -17,7 +17,7 @@ module m0 integer :: j end type contains - elemental subroutine assign0(lhs,rhs) + impure elemental subroutine assign0(lhs,rhs) class(component), intent(out) :: lhs class(component), intent(in) :: rhs lhs%i = 20 Index: gcc/testsuite/gfortran.dg/defined_assignment_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/defined_assignment_5.f90 (Revision 218978) +++ gcc/testsuite/gfortran.dg/defined_assignment_5.f90 (Arbeitskopie) @@ -38,7 +38,7 @@ module m1 integer :: j = 7 end type contains - elemental subroutine assign1(lhs,rhs) + impure elemental subroutine assign1(lhs,rhs) class(component1), intent(out) :: lhs class(component1), intent(in) :: rhs lhs%i = 30 Index: gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 =================================================================== --- gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 (Revision 218978) +++ gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90 (Arbeitskopie) @@ -15,7 +15,7 @@ module m_assertion_character procedure :: write => assertion_array_write end type t_assertion_character contains - elemental subroutine assertion_character( ast, name ) + impure elemental subroutine assertion_character( ast, name ) class(t_assertion_character), intent(out) :: ast character(len=*), intent(in) :: name ast%name = name @@ -37,7 +37,7 @@ module m_assertion_array_character procedure :: write => assertion_array_character_write end type t_assertion_array_character contains - pure subroutine assertion_array_character( ast, name, nast ) + subroutine assertion_array_character( ast, name, nast ) class(t_assertion_array_character), intent(out) :: ast character(len=*), intent(in) :: name integer, intent(in) :: nast Index: gcc/testsuite/gfortran.dg/typebound_operator_4.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Revision 218978) +++ gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Arbeitskopie) @@ -34,7 +34,7 @@ CONTAINS add_int = myint (a%value + b) END FUNCTION add_int - PURE SUBROUTINE assign_int (dest, from) + SUBROUTINE assign_int (dest, from) CLASS(myint), INTENT(OUT) :: dest INTEGER, INTENT(IN) :: from dest%value = from @@ -62,7 +62,6 @@ CONTAINS PURE SUBROUTINE iampure () TYPE(myint) :: x - x = 0 ! { dg-bogus "is not PURE" } x = x + 42 ! { dg-bogus "to a impure procedure" } x = x .PLUS. 5 ! { dg-bogus "to a impure procedure" } END SUBROUTINE iampure Index: gcc/testsuite/gfortran.dg/typebound_proc_16.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_proc_16.f03 (Revision 218978) +++ gcc/testsuite/gfortran.dg/typebound_proc_16.f03 (Arbeitskopie) @@ -27,7 +27,7 @@ MODULE rational_numbers r = REAL(this%n)/this%d END FUNCTION - ELEMENTAL SUBROUTINE rat_asgn_i(a,b) + impure ELEMENTAL SUBROUTINE rat_asgn_i(a,b) CLASS(rational),INTENT(OUT) :: a INTEGER,INTENT(IN) :: b a%n = b Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 =================================================================== --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 (Revision 218978) +++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 (Arbeitskopie) @@ -12,7 +12,7 @@ MODULE m PROCEDURE :: copy END TYPE t INTERFACE - PURE SUBROUTINE copy_proc_intr(a,b) + SUBROUTINE copy_proc_intr(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b END SUBROUTINE copy_proc_intr @@ -40,7 +40,7 @@ PROGRAM main CALL test%copy(copy_int,copy_x) ! PRINT '(*(I0,:2X))', copy_x CONTAINS - PURE SUBROUTINE copy_int(a,b) + SUBROUTINE copy_int(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b SELECT TYPE(a); TYPE IS(integer)