Patchwork [Fortran] PR fortran/34162: Internal procedure as actual argument

login
register
mail settings
Submitter Daniel Kraft
Date Sept. 3, 2010, 10:38 a.m.
Message ID <4C80D03B.8020409@domob.eu>
Download mbox | patch
Permalink /patch/63607/
State New
Headers show

Comments

Daniel Kraft - Sept. 3, 2010, 10:38 a.m.
Hi,

the attached patch implements the Fortran 2008 feature of internal 
procedures as actual arguments.  Since the middle-end already supports 
this natively, all that had to be done was update the resolve.c check 
accordingly.

I tried to add a challenging test-case, and it seems to work just like a 
charm.  This feature is hopefully quite useful, at least myself I would 
have liked to use it already some times.

Currently regtesting on GNU/Linux-x86-32.  Ok for trunk if no regressions?

Yours,
Daniel
Toon Moene - Sept. 3, 2010, 5:32 p.m.
Daniel Kraft wrote:

> This feature is hopefully quite useful, at least myself I would 
> have liked to use it already some times.

Well, you can deduce from the Note in the 2003 Standard discussed 
earlier that at least some on the committee were planning to (or had 
already) implement{ing/ed} the feature.

My experience on the committee tells me that commercial vendors do not 
implement features in compilers *outside the Standard they profess to 
support* without a good reason (think: "pecunia non olet").
H.J. Lu - Sept. 3, 2010, 6:10 p.m.
On Fri, Sep 3, 2010 at 3:38 AM, Daniel Kraft <d@domob.eu> wrote:
> Hi,
>
> the attached patch implements the Fortran 2008 feature of internal
> procedures as actual arguments.  Since the middle-end already supports this
> natively, all that had to be done was update the resolve.c check
> accordingly.
>
> I tried to add a challenging test-case, and it seems to work just like a
> charm.  This feature is hopefully quite useful, at least myself I would have
> liked to use it already some times.
>
> Currently regtesting on GNU/Linux-x86-32.  Ok for trunk if no regressions?
>
> Yours,
> Daniel
>
> --
> http://www.pro-vegan.info/
> --
> Done:  Arc-Bar-Cav-Kni-Ran-Rog-Sam-Tou-Val-Wiz
> To go: Hea-Mon-Pri
>
> 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.f03: Renamed from .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.
>

This may have caused:

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=45525

H.J.

Patch

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163798)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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)
Index: gcc/testsuite/gfortran.dg/internal_dummy_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/internal_dummy_2.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/internal_dummy_2.f08	(revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/internal_dummy_4.f08
===================================================================
--- gcc/testsuite/gfortran.dg/internal_dummy_4.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/internal_dummy_4.f08	(revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/internal_dummy_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/internal_dummy_1.f03	(revision 163797)
+++ gcc/testsuite/gfortran.dg/internal_dummy_1.f03	(working copy)
@@ -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

Index: gcc/testsuite/gfortran.dg/internal_dummy_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/internal_dummy_3.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/internal_dummy_3.f08	(revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/internal_dummy_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/internal_dummy_1.f90	(revision 163797)
+++ gcc/testsuite/gfortran.dg/internal_dummy_1.f90	(working copy)
@@ -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