summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/internal_dummy_3.f08
blob: 9780c27b3b4404c5952c5dd57ea2a59ca53e27f0 (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
65
66
! { 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

! { dg-final { cleanup-modules "m" } }