OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/34162 (F2008: Allow internal procedures as actual argument) 

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.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
This commit is contained in:
Daniel Kraft 2010-09-03 15:10:40 +02:00 committed by Daniel Kraft
parent 1c7b11d2a3
commit 5792039f79
7 changed files with 208 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
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

7
gcc/fortran/resolve.c
View File

@ -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)

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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

3
gcc/testsuite/gfortran.dg/internal_dummy_1.f90
View File

@ -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

64
gcc/testsuite/gfortran.dg/internal_dummy_2.f08 Normal file
View File

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

66
gcc/testsuite/gfortran.dg/internal_dummy_3.f08 Normal file
View File

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

57
gcc/testsuite/gfortran.dg/internal_dummy_4.f08 Normal file
View File

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