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.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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163813
138bc75d-0d04-0410-961f-
82ee72b054a4
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/44602
* gfortran.h (struct gfc_code): Renamed `whichloop' to
`which_construct' as this is no longer restricted to loops.
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)
+2010-09-03 Daniel Kraft <d@domob.eu>
+
+ 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 <jakub@redhat.com>
PR debug/45500
! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
OSDN Git Service
