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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [proc_decl_2.f90] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log


! { dg-do run }
! Various runtime tests of PROCEDURE declarations.
! Contributed by Janus Weil 
 
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
 
! { dg-final { cleanup-modules "m" } }

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`! Various runtime tests of PROCEDURE declarations.`
3			`! Contributed by Janus Weil`
4
5			`module m`
6
7			`use ISO_C_BINDING`
8
9			`abstract interface`
10			`subroutine csub() bind(c)`
11			`end subroutine csub`
12			`end interface`
13
14			`integer, parameter :: ckind = C_FLOAT_COMPLEX`
15			`abstract interface`
16			`function stub() bind(C)`
17			`import ckind`
18			`complex(ckind) stub`
19			`end function`
20			`end interface`
21
22			`procedure():: mp1`
23			`procedure(real), private:: mp2`
24			`procedure(mfun), public:: mp3`
25			`procedure(csub), public, bind(c) :: c, d`
26			`procedure(csub), public, bind(c, name="myB") :: b`
27			`procedure(stub), bind(C) :: e`
28
29			`contains`
30
31			`real function mfun(x,y)`
32			`real x,y`
33			`mfun=4.2`
34			`end function`
35
36			`subroutine bar(a,b)`
37			`implicit none`
38			`interface`
39			`subroutine a()`
40			`end subroutine a`
41			`end interface`
42			`optional :: a`
43			`procedure(a), optional :: b`
44			`end subroutine bar`
45
46			`subroutine bar2(x)`
47			`abstract interface`
48			`character function abs_fun()`
49			`end function`
50			`end interface`
51			`procedure(abs_fun):: x`
52			`end subroutine`
53
54
55			`end module`
56
57
58			`program p`
59			`implicit none`
60
61			`abstract interface`
62			`subroutine abssub(x)`
63			`real x`
64			`end subroutine`
65			`end interface`
66
67			`integer i`
68			`real r`
69
70			`procedure(integer):: p1`
71			`procedure(fun):: p2`
72			`procedure(abssub):: p3`
73			`procedure(sub):: p4`
74			`procedure():: p5`
75			`procedure(p4):: p6`
76			`procedure(integer) :: p7`
77
78			`i=p1()`
79			`if (i /= 5) call abort()`
80			`i=p2(3.1)`
81			`if (i /= 3) call abort()`
82			`r=4.2`
83			`call p3(r)`
84			`if (abs(r-5.2)>1e-6) call abort()`
85			`call p4(r)`
86			`if (abs(r-3.7)>1e-6) call abort()`
87			`call p5()`
88			`call p6(r)`
89			`if (abs(r-7.4)>1e-6) call abort()`
90			`i=p7(4)`
91			`if (i /= -8) call abort()`
92			`r=dummytest(p3)`
93			`if (abs(r-2.1)>1e-6) call abort()`
94
95			`contains`
96
97			`integer function fun(x)`
98			`real x`
99			`fun=7`
100			`end function`
101
102			`subroutine sub(x)`
103			`real x`
104			`end subroutine`
105
106			`real function dummytest(dp)`
107			`procedure(abssub):: dp`
108			`real y`
109			`y=1.1`
110			`call dp(y)`
111			`dummytest=y`
112			`end function`
113
114			`end program p`
115
116
117			`integer function p1()`
118			`p1 = 5`
119			`end function`
120
121			`integer function p2(x)`
122			`real x`
123			`p2 = int(x)`
124			`end function`
125
126			`subroutine p3(x)`
127			`real,intent(inout):: x`
128			`x=x+1.0`
129			`end subroutine`
130
131			`subroutine p4(x)`
132			`real,intent(inout):: x`
133			`x=x-1.5`
134			`end subroutine`
135
136			`subroutine p5()`
137			`end subroutine`
138
139			`subroutine p6(x)`
140			`real,intent(inout):: x`
141			`x=x*2.`
142			`end subroutine`
143
144			`function p7(x)`
145			`implicit none`
146			`integer :: x, p7`
147			`p7 = x*(-2)`
148			`end function`
149
150			`! { dg-final { cleanup-modules "m" } }`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [proc_decl_2.f90] - Blame information for rev 801