blob: ff8dd822ec3d8f37b8fc0ee0949366a8bbb1daec (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics" }
! 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
|
