This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PR fortran/34162: Internal procedure as actual argument
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Fri, 03 Sep 2010 12:38:51 +0200
- Subject: [Patch, Fortran] PR fortran/34162: Internal procedure as actual argument
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
--
http://www.pro-vegan.info/
--
Done: Arc-Bar-Cav-Kni-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Mon-Pri
2010-09-03 Daniel Kraft <d@domob.eu>
PR fortran/34162
* resolve.c (resolve_actual_arglist): Allow internal procedure
as actual argument with Fortran 2008.
2010-09-03 Daniel Kraft <d@domob.eu>
PR fortran/34162
* gfortran.dg/internal_dummy_1.f03: Renamed from .f90, add -std=f2003.
* gfortran.dg/internal_dummy_2.f08: New test.
* gfortran.dg/internal_dummy_3.f08: New test.
* gfortran.dg/internal_dummy_4.f08: New test.
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 <jv244@cam.ac.uk>
!
-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 <jv244@cam.ac.uk>
-!
-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