OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [internal_dummy_3.f08] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { 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
65
 
66
! { dg-final { cleanup-modules "m" } }

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.