|
111
|
1 ! { dg-do run }
|
|
131
|
2 ! { dg-options "-std=f2008 " }
|
|
111
|
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
|
|
131
|
28 IF (current () /= level - 1) STOP 1
|
|
111
|
29 END IF
|
|
|
30
|
|
|
31 IF (PRESENT (previous)) THEN
|
|
131
|
32 IF (previous () /= level - 2) STOP 2
|
|
111
|
33 END IF
|
|
|
34
|
|
|
35 IF (level == 1) THEN
|
|
|
36 first => myLevel
|
|
|
37 END IF
|
|
131
|
38 IF (first () /= 1) STOP 3
|
|
111
|
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
|
