Subversion Repositories openrisc

! { 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" } }