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

gcc/fortran/ChangeLog

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

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 "
+	      if (gfc_notify_std (GFC_STD_F2008,
-			 "actual argument at %L", sym->name, &e->where);
+				  "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)

gcc/testsuite/ChangeLog

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

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

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

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

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