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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
!
3
! PR 40593: Proc-pointer returning function as actual argument
4
!
5
! Original test case by Tobias Burnus 
6
! Modified by Janus Weil
7
 
8
module m
9
contains
10
  subroutine sub(a)
11
    integer :: a
12
    a = 42
13
  end subroutine
14
  integer function func()
15
    func = 42
16
  end function
17
end module m
18
 
19
program test
20
  use m
21
  implicit none
22
  call caller1(getPtr1())
23
  call caller2(getPtr2())
24
  call caller3(getPtr2())
25
contains
26
  subroutine caller1(s)
27
    procedure(sub) :: s
28
    integer :: b
29
    call s(b)
30
    if (b /= 42)  call abort()
31
  end subroutine
32
  subroutine caller2(f)
33
    procedure(integer) :: f
34
    if (f() /= 42)  call abort()
35
  end subroutine
36
  subroutine caller3(f)
37
    procedure(func),pointer :: f
38
    if (f() /= 42) call abort()
39
  end subroutine
40
  function getPtr1()
41
    procedure(sub), pointer :: getPtr1
42
    getPtr1 => sub
43
  end function
44
  function getPtr2()
45
    procedure(func), pointer :: getPtr2
46
    getPtr2 => func
47
  end function
48
end program test
49
 
50
! { dg-final { cleanup-modules "m" } }
51
 

powered by: WebSVN 2.1.0

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