gcc/testsuite/gfortran.dg/internal_dummy_3.f08

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2008 -fall-intrinsics" }
   3
   4 ! PR fortran/34162
   5 ! Internal procedures as actual arguments (like restricted closures).
   6 ! More challenging test involving recursion.
   7
   8 ! Contributed by Daniel Kraft, d@domob.eu.
   9
  10 MODULE m
  11   IMPLICIT NONE
  12
  13   ABSTRACT INTERFACE
  14     FUNCTION returnValue ()
  15       INTEGER :: returnValue
  16     END FUNCTION returnValue
  17   END INTERFACE
  18
  19   PROCEDURE(returnValue), POINTER :: first
  20
  21 CONTAINS
  22
  23   RECURSIVE SUBROUTINE test (level, current, previous)
  24     INTEGER, INTENT(IN) :: level
  25     PROCEDURE(returnValue), OPTIONAL :: previous, current
  26
  27     IF (PRESENT (current)) THEN
  28       IF (current () /= level - 1) CALL abort ()
  29     END IF
  30
  31     IF (PRESENT (previous)) THEN
  32       IF (previous () /= level - 2) CALL abort ()
  33     END IF
  34
  35     IF (level == 1) THEN
  36       first => myLevel
  37     END IF
  38     IF (first () /= 1) CALL abort ()
  39
  40     IF (level == 10) RETURN
  41
  42     IF (PRESENT (current)) THEN
  43       CALL test (level + 1, myLevel, current)
  44     ELSE
  45       CALL test (level + 1, myLevel)
  46     END IF
  47
  48   CONTAINS
  49
  50     FUNCTION myLevel ()
  51       INTEGER :: myLevel
  52       myLevel = level
  53     END FUNCTION myLevel
  54
  55   END SUBROUTINE test
  56
  57 END MODULE m
  58
  59 PROGRAM main
  60   USE :: m
  61   IMPLICIT NONE
  62
  63   CALL test (1)
  64 END PROGRAM main