From patchwork Thu Aug 5 19:40:57 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 61016 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 AB040B6F06 for ; Fri, 6 Aug 2010 05:36:04 +1000 (EST) Received: (qmail 23652 invoked by alias); 5 Aug 2010 19:35:59 -0000 Received: (qmail 23631 invoked by uid 22791); 5 Aug 2010 19:35:57 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 05 Aug 2010 19:35:50 +0000 Received: from paris.xoc.tele2net.at ([213.90.36.7]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1Oh6EF-0003QE-VZ; Thu, 05 Aug 2010 21:35:47 +0200 Received: from d86-33-197-26.cust.tele2.at ([86.33.197.26] helo=[192.168.1.18]) by paris.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1Oh6EF-0001s0-KY; Thu, 05 Aug 2010 21:35:47 +0200 Message-ID: <4C5B13C9.10905@domob.eu> Date: Thu, 05 Aug 2010 21:40:57 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: [Patch, Fortran] PR fortran/45197: F2008: Allow IMPURE elemental procedures 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 Hi, the small patch attached implements the F2008 attribute IMPURE that may be given to procedures; this may be used to get ELEMENTAL procedures that are not also PURE (as is the default). Instead of checking (attr.pure || attr.elemental) in gfc_pure, only attr.pure is checked -- which seems also cleaner to me. Instead, attr.pure is set if ELEMENTAL but not IMPURE was parsed. No regressions on GNU/Linux-x86-32. Ok for trunk? Daniel Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (revision 162915) +++ gcc/fortran/decl.c (working copy) @@ -3979,45 +3979,81 @@ match gfc_match_prefix (gfc_typespec *ts) { bool seen_type; + bool seen_impure; + bool found_prefix; gfc_clear_attr (¤t_attr); - seen_type = 0; + seen_type = false; + seen_impure = false; gcc_assert (!gfc_matching_prefix); gfc_matching_prefix = true; -loop: - if (!seen_type && ts != NULL - && gfc_match_decl_type_spec (ts, 0) == MATCH_YES - && gfc_match_space () == MATCH_YES) + do { + found_prefix = false; - seen_type = 1; - goto loop; - } + if (!seen_type && ts != NULL + && gfc_match_decl_type_spec (ts, 0) == MATCH_YES + && gfc_match_space () == MATCH_YES) + { - if (gfc_match ("elemental% ") == MATCH_YES) - { - if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) - goto error; + seen_type = true; + found_prefix = true; + } + + if (gfc_match ("elemental% ") == MATCH_YES) + { + if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + if (gfc_match ("pure% ") == MATCH_YES) + { + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } - goto loop; + if (gfc_match ("recursive% ") == MATCH_YES) + { + if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + /* IMPURE is a somewhat special case, as it needs not set an actual + attribute but rather only prevents ELEMENTAL routines from being + automatically PURE. */ + if (gfc_match ("impure% ") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: IMPURE procedure at %C") + == FAILURE) + goto error; + + seen_impure = true; + found_prefix = true; + } } + while (found_prefix); - if (gfc_match ("pure% ") == MATCH_YES) + /* IMPURE and PURE must not both appear, of course. */ + if (seen_impure && current_attr.pure) { - if (gfc_add_pure (¤t_attr, NULL) == FAILURE) - goto error; - - goto loop; + gfc_error ("PURE and IMPURE must not appear both at %C"); + goto error; } - if (gfc_match ("recursive% ") == MATCH_YES) + /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ + if (!seen_impure && current_attr.elemental && !current_attr.pure) { - if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) goto error; - - goto loop; } /* At this point, the next item is not a prefix. */ Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 162915) +++ gcc/fortran/resolve.c (working copy) @@ -12438,7 +12438,7 @@ gfc_pure (gfc_symbol *sym) if (sym == NULL) return 0; attr = sym->attr; - if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental)) + if (attr.flavor == FL_PROCEDURE && attr.pure) return 1; } return 0; @@ -12446,7 +12446,7 @@ gfc_pure (gfc_symbol *sym) attr = sym->attr; - return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental); + return attr.flavor == FL_PROCEDURE && attr.pure; } Index: gcc/testsuite/gfortran.dg/impure_2.f08 =================================================================== --- gcc/testsuite/gfortran.dg/impure_2.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/impure_2.f08 (revision 0) @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! PR fortran/45197 +! Check for errors with IMPURE. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + +CONTAINS + + IMPURE PURE SUBROUTINE foobar () ! { dg-error "must not appear both" } + + PURE ELEMENTAL IMPURE FUNCTION xyz () ! { dg-error "must not appear both" } + + IMPURE ELEMENTAL SUBROUTINE mysub () + END SUBROUTINE mysub + + PURE SUBROUTINE purified () + CALL mysub () ! { dg-error "is not PURE" } + END SUBROUTINE purified + +END MODULE m + +! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/impure_1.f08 =================================================================== --- gcc/testsuite/gfortran.dg/impure_1.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/impure_1.f08 (revision 0) @@ -0,0 +1,71 @@ +! { dg-do run } +! { dg-options "-std=f2008 -fall-intrinsics" } + +! PR fortran/45197 +! Check that IMPURE and IMPURE ELEMENTAL in particular works. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + INTEGER, PARAMETER :: n = 5 + + INTEGER :: i + INTEGER :: arr(n) + +CONTAINS + + ! This ought to work (without any effect). + IMPURE SUBROUTINE foobar () + END SUBROUTINE foobar + + IMPURE ELEMENTAL SUBROUTINE impureSub (a) + INTEGER, INTENT(IN) :: a + + arr(i) = a + i = i + 1 + + PRINT *, a + END SUBROUTINE impureSub + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + INTEGER :: a(n), b(n), s + + a = (/ (i, i = 1, n) /) + + ! Traverse in forward order. + s = 0 + b = accumulate (a, s) + IF (ANY (b /= (/ 1, 3, 6, 10, 15 /))) CALL abort () + + ! And now backward. + s = 0 + b = accumulate (a(n:1:-1), s) + IF (ANY (b /= (/ 5, 9, 12, 14, 15 /))) CALL abort () + + ! Use subroutine. + i = 1 + arr = 0 + CALL impureSub (a) + IF (ANY (arr /= a)) CALL abort () + +CONTAINS + + IMPURE ELEMENTAL FUNCTION accumulate (a, s) + INTEGER, INTENT(IN) :: a + INTEGER, INTENT(INOUT) :: s + INTEGER :: accumulate + + s = s + a + accumulate = s + END FUNCTION accumulate + +END PROGRAM main + +! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/impure_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/impure_3.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/impure_3.f90 (revision 0) @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/45197 +! Check that IMPURE gets rejected without F2008. + +! Contributed by Daniel Kraft, d@domob.eu. + +IMPURE SUBROUTINE foobar () ! { dg-error "Fortran 2008" } + +IMPURE ELEMENTAL FUNCTION xyz () ! { dg-error "Fortran 2008" } Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 162915) +++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy) @@ -59,7 +59,7 @@ MODULE testmod PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" } PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure. PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental. - PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" } + PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be" } PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental. PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" }