summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/proc_decl_2.f90
blob: a16b4db5f019613af7306373793c6c12dd7b2471 (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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
! { dg-do run }
! Various runtime tests of PROCEDURE declarations.
! Contributed by Janus Weil <jaydub66@gmail.com>

module m

  use ISO_C_BINDING

  abstract interface
    subroutine csub() bind(c)
    end subroutine csub
  end interface

  integer, parameter :: ckind = C_FLOAT_COMPLEX
  abstract interface
    function stub() bind(C)
      import ckind
      complex(ckind) stub
    end function
  end interface

  procedure():: mp1
  procedure(real), private:: mp2
  procedure(mfun), public:: mp3
  procedure(csub), public, bind(c) :: c, d
  procedure(csub), public, bind(c, name="myB") :: b
  procedure(stub), bind(C) :: e

contains

  real function mfun(x,y)
    real x,y
    mfun=4.2
  end function

  subroutine bar(a,b)
    implicit none
    interface
      subroutine a()
      end subroutine a
    end interface
    optional ::  a
    procedure(a), optional :: b
  end subroutine bar

  subroutine bar2(x)
    abstract interface
      character function abs_fun()
      end function
    end interface
    procedure(abs_fun):: x
  end subroutine


end module


program p
  implicit none

  abstract interface
    subroutine abssub(x)
      real x
    end subroutine
  end interface

  integer i
  real r

  procedure(integer):: p1
  procedure(fun):: p2
  procedure(abssub):: p3
  procedure(sub):: p4
  procedure():: p5
  procedure(p4):: p6
  procedure(integer) :: p7

  i=p1()
  if (i /= 5) call abort()
  i=p2(3.1)
  if (i /= 3) call abort()
  r=4.2
  call p3(r)
  if (abs(r-5.2)>1e-6) call abort()
  call p4(r)
  if (abs(r-3.7)>1e-6) call abort()
  call p5()
  call p6(r)
  if (abs(r-7.4)>1e-6) call abort()
  i=p7(4)
  if (i /= -8) call abort()
  r=dummytest(p3)
  if (abs(r-2.1)>1e-6) call abort()

contains

  integer function fun(x)
    real x
    fun=7
  end function

  subroutine sub(x)
    real x
  end subroutine

  real function dummytest(dp)
    procedure(abssub):: dp
    real y
    y=1.1
    call dp(y)
    dummytest=y
  end function

end program p


integer function p1()
  p1 = 5
end function

integer function p2(x)
  real x
  p2 = int(x)
end function

subroutine p3(x)
  real,intent(inout):: x
  x=x+1.0
end subroutine

subroutine p4(x)
  real,intent(inout):: x
  x=x-1.5
end subroutine

subroutine p5()
end subroutine

subroutine p6(x)
  real,intent(inout):: x
  x=x*2.
end subroutine

function p7(x)
 implicit none
 integer :: x, p7
 p7 = x*(-2)
end function