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

Subversion Repositories openrisc

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

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


! { dg-do run }
!
! PR 36704: Procedure pointer as function result
!
! Contributed by Janus Weil 
 
module mo
contains
 
  function j()
    implicit none
    procedure(integer),pointer :: j
    intrinsic iabs
    j => iabs
  end function
 
  subroutine sub(y)
    integer,intent(inout) :: y
    y = y**2
  end subroutine
 
end module
 
 
program proc_ptr_14
use mo
implicit none
intrinsic :: iabs
integer :: x
procedure(integer),pointer :: p,p2
procedure(sub),pointer :: ps
 
p => a()
if (p(-1)/=1) call abort()
p => b()
if (p(-2)/=2) call abort()
p => c()
if (p(-3)/=3) call abort()
 
ps => d()
x = 4
call ps(x)
if (x/=16) call abort()
 
p => dd()
if (p(-4)/=4) call abort()
 
ps => e(sub)
x = 5
call ps(x)
if (x/=25) call abort()
 
p => ee()
if (p(-5)/=5) call abort()
p => f()
if (p(-6)/=6) call abort()
p => g()
if (p(-7)/=7) call abort()
 
ps => h(sub)
x = 2
call ps(x)
if (x/=4) call abort()
 
p => i()
if (p(-8)/=8) call abort()
p => j()
if (p(-9)/=9) call abort()
 
p => k(p2)
if (p(-10)/=p2(-10)) call abort()
 
p => l()
if (p(-11)/=11) call abort()
 
contains
 
  function a()
    procedure(integer),pointer :: a
    a => iabs
  end function
 
  function b()
    procedure(integer) :: b
    pointer :: b
    b => iabs
  end function
 
  function c()
    pointer :: c
    procedure(integer) :: c
    c => iabs
  end function
 
  function d()
    pointer :: d
    external d
    d => sub
  end function
 
  function dd()
    pointer :: dd
    external :: dd
    integer :: dd
    dd => iabs
  end function
 
  function e(arg)
    external :: e,arg
    pointer :: e
    e => arg
  end function
 
  function ee()
    integer :: ee
    external :: ee
    pointer :: ee
    ee => iabs
  end function
 
  function f()
    pointer :: f
    interface
      integer function f(x)
        integer,intent(in) :: x
      end function
    end interface
    f => iabs
  end function
 
  function g()
    interface
      integer function g(x)
        integer,intent(in) :: x
      end function g
    end interface
    pointer :: g
    g => iabs
  end function
 
  function h(arg)
    interface
      subroutine arg(b)
        integer,intent(inout) :: b
      end subroutine arg
    end interface
    pointer :: h
    interface
      subroutine h(a)
        integer,intent(inout) :: a
      end subroutine h
    end interface
    h => arg
  end function
 
  function i()
    pointer :: i
    interface
      function i(x)
        integer :: i,x
        intent(in) :: x
      end function i
    end interface
    i => iabs
  end function
 
  function k(arg)
    procedure(integer),pointer :: k,arg
    k => iabs
    arg => k
  end function
 
  function l()
    procedure(iabs),pointer :: l
    integer :: i
    l => iabs
    if (l(-11)/=11) call abort()
  end function
 
end
 
! { dg-final { cleanup-modules "mo" } }
 

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`!`
3			`! PR 36704: Procedure pointer as function result`
4			`!`
5			`! Contributed by Janus Weil`
6
7			`module mo`
8			`contains`
9
10			`function j()`
11			`implicit none`
12			`procedure(integer),pointer :: j`
13			`intrinsic iabs`
14			`j => iabs`
15			`end function`
16
17			`subroutine sub(y)`
18			`integer,intent(inout) :: y`
19			`y = y**2`
20			`end subroutine`
21
22			`end module`
23
24
25			`program proc_ptr_14`
26			`use mo`
27			`implicit none`
28			`intrinsic :: iabs`
29			`integer :: x`
30			`procedure(integer),pointer :: p,p2`
31			`procedure(sub),pointer :: ps`
32
33			`p => a()`
34			`if (p(-1)/=1) call abort()`
35			`p => b()`
36			`if (p(-2)/=2) call abort()`
37			`p => c()`
38			`if (p(-3)/=3) call abort()`
39
40			`ps => d()`
41			`x = 4`
42			`call ps(x)`
43			`if (x/=16) call abort()`
44
45			`p => dd()`
46			`if (p(-4)/=4) call abort()`
47
48			`ps => e(sub)`
49			`x = 5`
50			`call ps(x)`
51			`if (x/=25) call abort()`
52
53			`p => ee()`
54			`if (p(-5)/=5) call abort()`
55			`p => f()`
56			`if (p(-6)/=6) call abort()`
57			`p => g()`
58			`if (p(-7)/=7) call abort()`
59
60			`ps => h(sub)`
61			`x = 2`
62			`call ps(x)`
63			`if (x/=4) call abort()`
64
65			`p => i()`
66			`if (p(-8)/=8) call abort()`
67			`p => j()`
68			`if (p(-9)/=9) call abort()`
69
70			`p => k(p2)`
71			`if (p(-10)/=p2(-10)) call abort()`
72
73			`p => l()`
74			`if (p(-11)/=11) call abort()`
75
76			`contains`
77
78			`function a()`
79			`procedure(integer),pointer :: a`
80			`a => iabs`
81			`end function`
82
83			`function b()`
84			`procedure(integer) :: b`
85			`pointer :: b`
86			`b => iabs`
87			`end function`
88
89			`function c()`
90			`pointer :: c`
91			`procedure(integer) :: c`
92			`c => iabs`
93			`end function`
94
95			`function d()`
96			`pointer :: d`
97			`external d`
98			`d => sub`
99			`end function`
100
101			`function dd()`
102			`pointer :: dd`
103			`external :: dd`
104			`integer :: dd`
105			`dd => iabs`
106			`end function`
107
108			`function e(arg)`
109			`external :: e,arg`
110			`pointer :: e`
111			`e => arg`
112			`end function`
113
114			`function ee()`
115			`integer :: ee`
116			`external :: ee`
117			`pointer :: ee`
118			`ee => iabs`
119			`end function`
120
121			`function f()`
122			`pointer :: f`
123			`interface`
124			`integer function f(x)`
125			`integer,intent(in) :: x`
126			`end function`
127			`end interface`
128			`f => iabs`
129			`end function`
130
131			`function g()`
132			`interface`
133			`integer function g(x)`
134			`integer,intent(in) :: x`
135			`end function g`
136			`end interface`
137			`pointer :: g`
138			`g => iabs`
139			`end function`
140
141			`function h(arg)`
142			`interface`
143			`subroutine arg(b)`
144			`integer,intent(inout) :: b`
145			`end subroutine arg`
146			`end interface`
147			`pointer :: h`
148			`interface`
149			`subroutine h(a)`
150			`integer,intent(inout) :: a`
151			`end subroutine h`
152			`end interface`
153			`h => arg`
154			`end function`
155
156			`function i()`
157			`pointer :: i`
158			`interface`
159			`function i(x)`
160			`integer :: i,x`
161			`intent(in) :: x`
162			`end function i`
163			`end interface`
164			`i => iabs`
165			`end function`
166
167			`function k(arg)`
168			`procedure(integer),pointer :: k,arg`
169			`k => iabs`
170			`arg => k`
171			`end function`
172
173			`function l()`
174			`procedure(iabs),pointer :: l`
175			`integer :: i`
176			`l => iabs`
177			`if (l(-11)/=11) call abort()`
178			`end function`
179
180			`end`
181
182			`! { dg-final { cleanup-modules "mo" } }`
183

Browse

Tools

Subversion Repositories openrisc

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