From: Daniel Kraft Date: Fri, 3 Sep 2010 13:10:40 +0000 (+0200) Subject: re PR fortran/34162 (F2008: Allow internal procedures as actual argument) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=5792039f7980518c65a21c69e7205a8752a41553;p=gcc.git re PR fortran/34162 (F2008: Allow internal procedures as actual argument) 2010-09-03 Daniel Kraft PR fortran/34162 * resolve.c (resolve_actual_arglist): Allow internal procedure as actual argument with Fortran 2008. 2010-09-03 Daniel Kraft PR fortran/34162 * gfortran.dg/internal_dummy_1.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. From-SVN: r163813 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7c75e503efb..ad46b0aaede 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2010-09-03 Daniel Kraft + + PR fortran/34162 + * resolve.c (resolve_actual_arglist): Allow internal procedure + as actual argument with Fortran 2008. + 2010-09-03 Daniel Kraft PR fortran/44602 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4b6ac1d7870..88f43cdfcbf 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1590,8 +1590,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, 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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5b089016c6c..d27f8695f4c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2010-09-03 Daniel Kraft + + PR fortran/34162 + * gfortran.dg/internal_dummy_1.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. + 2010-09-03 Jakub Jelinek PR debug/45500 diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 index cae187e808b..28ca7a4b47a 100644 --- a/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 +++ b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_2.f08 b/gcc/testsuite/gfortran.dg/internal_dummy_2.f08 new file mode 100644 index 00000000000..c6adcc57d72 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_dummy_2.f08 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_3.f08 b/gcc/testsuite/gfortran.dg/internal_dummy_3.f08 new file mode 100644 index 00000000000..b5a50ee6c6c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_dummy_3.f08 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_4.f08 b/gcc/testsuite/gfortran.dg/internal_dummy_4.f08 new file mode 100644 index 00000000000..1d8b8b2288e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_dummy_4.f08 @@ -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" } }