===================================================================
@@ -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)
===================================================================
@@ -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" } }
===================================================================
@@ -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" } }
===================================================================
@@ -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
===================================================================
@@ -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" } }
===================================================================
@@ -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