From patchwork Fri Sep 3 10:38:51 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 63607 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 4229EB716E for ; Fri, 3 Sep 2010 20:34:18 +1000 (EST) Received: (qmail 1525 invoked by alias); 3 Sep 2010 10:34:14 -0000 Received: (qmail 1480 invoked by uid 22791); 3 Sep 2010 10:34:10 -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; Fri, 03 Sep 2010 10:33:30 +0000 Received: from patricia.xoc.tele2net.at ([213.90.36.9]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OrTaJ-0006vp-Ib; Fri, 03 Sep 2010 12:33:27 +0200 Received: from d86-32-16-99.cust.tele2.at ([86.32.16.99] helo=[192.168.1.18]) by patricia.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OrTaJ-0002pR-8F; Fri, 03 Sep 2010 12:33:27 +0200 Message-ID: <4C80D03B.8020409@domob.eu> Date: Fri, 03 Sep 2010 12:38:51 +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/34162: Internal procedure as actual argument 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 attached patch implements the Fortran 2008 feature of internal procedures as actual arguments. Since the middle-end already supports this natively, all that had to be done was update the resolve.c check accordingly. I tried to add a challenging test-case, and it seems to work just like a charm. This feature is hopefully quite useful, at least myself I would have liked to use it already some times. Currently regtesting on GNU/Linux-x86-32. Ok for trunk if no regressions? Yours, Daniel Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 163798) +++ gcc/fortran/resolve.c (working copy) @@ -1590,8 +1590,11 @@ resolve_actual_arglist (gfc_actual_argli if (sym->attr.contained && !sym->attr.use_assoc && sym->ns->proc_name->attr.flavor != FL_MODULE) { - gfc_error ("Internal procedure '%s' is not allowed as an " - "actual argument at %L", sym->name, &e->where); + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: Internal procedure '%s' is" + " used as actual argument at %L", + sym->name, &e->where) == FAILURE) + return FAILURE; } if (sym->attr.elemental && !sym->attr.intrinsic) Index: gcc/testsuite/gfortran.dg/internal_dummy_2.f08 =================================================================== --- gcc/testsuite/gfortran.dg/internal_dummy_2.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/internal_dummy_2.f08 (revision 0) @@ -0,0 +1,64 @@ +! { dg-do run } +! [ dg-options "-std=f2008" } + +! PR fortran/34162 +! Internal procedures as actual arguments (like restricted closures). +! Check it works basically. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + ABSTRACT INTERFACE + FUNCTION returnValue () + INTEGER :: returnValue + END FUNCTION returnValue + + SUBROUTINE doSomething () + END SUBROUTINE doSomething + END INTERFACE + +CONTAINS + + FUNCTION callIt (proc) + PROCEDURE(returnValue) :: proc + INTEGER :: callIt + + callIt = proc () + END FUNCTION callIt + + SUBROUTINE callSub (proc) + PROCEDURE(doSomething) :: proc + + CALL proc () + END SUBROUTINE callSub + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + INTEGER :: a + + a = 42 + IF (callIt (myA) /= 42) CALL abort () + + CALL callSub (incA) + IF (a /= 43) CALL abort () + +CONTAINS + + FUNCTION myA () + INTEGER :: myA + myA = a + END FUNCTION myA + + SUBROUTINE incA () + a = a + 1 + END SUBROUTINE incA + +END PROGRAM main + +! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/internal_dummy_4.f08 =================================================================== --- gcc/testsuite/gfortran.dg/internal_dummy_4.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/internal_dummy_4.f08 (revision 0) @@ -0,0 +1,57 @@ +! { dg-do run } +! PR fortran/34133 +! PR fortran/34162 +! +! Test of using internal bind(C) procedures as +! actual argument. Bind(c) on internal procedures and +! internal procedures are actual argument are +! Fortran 2008 (draft) extension. +! +module test_mod + use iso_c_binding + implicit none +contains + subroutine test_sub(a, arg, res) + interface + subroutine a(x) bind(C) + import + integer(c_int), intent(inout) :: x + end subroutine a + end interface + integer(c_int), intent(inout) :: arg + integer(c_int), intent(in) :: res + call a(arg) + if(arg /= res) call abort() + end subroutine test_sub + subroutine test_func(a, arg, res) + interface + integer(c_int) function a(x) bind(C) + import + integer(c_int), intent(in) :: x + end function a + end interface + integer(c_int), intent(in) :: arg + integer(c_int), intent(in) :: res + if(a(arg) /= res) call abort() + end subroutine test_func +end module test_mod + +program main + use test_mod + implicit none + integer :: a + a = 33 + call test_sub (one, a, 7*33) + a = 23 + call test_func(two, a, -123*23) +contains + subroutine one(x) bind(c) + integer(c_int),intent(inout) :: x + x = 7*x + end subroutine one + integer(c_int) function two(y) bind(c) + integer(c_int),intent(in) :: y + two = -123*y + end function two +end program main +! { dg-final { cleanup-modules "test_mod" } } Index: gcc/testsuite/gfortran.dg/internal_dummy_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/internal_dummy_1.f03 (revision 163797) +++ gcc/testsuite/gfortran.dg/internal_dummy_1.f03 (working copy) @@ -1,10 +1,11 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! Tests the fix for 20861, in which internal procedures were permitted to ! be dummy arguments. ! ! Contributed by Joost VandeVondele ! -CALL DD(TT) ! { dg-error "is not allowed as an actual argument" } +CALL DD(TT) ! { dg-error "Fortran 2008: Internal procedure 'tt' is used as actual argument" } CONTAINS SUBROUTINE DD(F) INTERFACE Property changes on: gcc/testsuite/gfortran.dg/internal_dummy_1.f03 ___________________________________________________________________ Added: svn:mergeinfo Index: gcc/testsuite/gfortran.dg/internal_dummy_3.f08 =================================================================== --- gcc/testsuite/gfortran.dg/internal_dummy_3.f08 (revision 0) +++ gcc/testsuite/gfortran.dg/internal_dummy_3.f08 (revision 0) @@ -0,0 +1,66 @@ +! { dg-do run } +! [ dg-options "-std=f2008" } + +! PR fortran/34162 +! Internal procedures as actual arguments (like restricted closures). +! More challenging test involving recursion. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + ABSTRACT INTERFACE + FUNCTION returnValue () + INTEGER :: returnValue + END FUNCTION returnValue + END INTERFACE + + PROCEDURE(returnValue), POINTER :: first + +CONTAINS + + RECURSIVE SUBROUTINE test (level, current, previous) + INTEGER, INTENT(IN) :: level + PROCEDURE(returnValue), OPTIONAL :: previous, current + + IF (PRESENT (current)) THEN + IF (current () /= level - 1) CALL abort () + END IF + + IF (PRESENT (previous)) THEN + IF (previous () /= level - 2) CALL abort () + END IF + + IF (level == 1) THEN + first => myLevel + END IF + IF (first () /= 1) CALL abort () + + IF (level == 10) RETURN + + IF (PRESENT (current)) THEN + CALL test (level + 1, myLevel, current) + ELSE + CALL test (level + 1, myLevel) + END IF + + CONTAINS + + FUNCTION myLevel () + INTEGER :: myLevel + myLevel = level + END FUNCTION myLevel + + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + CALL test (1) +END PROGRAM main + +! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/internal_dummy_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/internal_dummy_1.f90 (revision 163797) +++ gcc/testsuite/gfortran.dg/internal_dummy_1.f90 (working copy) @@ -1,19 +0,0 @@ -! { dg-do compile } -! Tests the fix for 20861, in which internal procedures were permitted to -! be dummy arguments. -! -! Contributed by Joost VandeVondele -! -CALL DD(TT) ! { dg-error "is not allowed as an actual argument" } -CONTAINS -SUBROUTINE DD(F) - INTERFACE - SUBROUTINE F(X) - REAL :: X - END SUBROUTINE F - END INTERFACE -END SUBROUTINE DD -SUBROUTINE TT(X) - REAL :: X -END SUBROUTINE -END