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_3.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 36704: Procedure pointer as function result
4
!
5
! Original test case from James Van Buskirk.
6
!
7
! Adapted by Janus Weil 
8
 
9
module store_subroutine
10
   implicit none
11
 
12
   abstract interface
13
      subroutine sub(i)
14
        integer, intent(inout) :: i
15
      end subroutine sub
16
   end interface
17
 
18
   procedure(sub), pointer, private :: psub => NULL()
19
 
20
contains
21
 
22
   subroutine set_sub(x)
23
      procedure(sub) x
24
      psub => x
25
   end subroutine set_sub
26
 
27
   function get_sub()
28
      procedure(sub), pointer :: get_sub
29
      get_sub => psub
30
   end function get_sub
31
 
32
end module store_subroutine
33
 
34
program test
35
   use store_subroutine
36
   implicit none
37
   procedure(sub), pointer :: qsub
38
   integer :: k = 1
39
 
40
   call my_sub(k)
41
   if (k/=3) call abort
42
   qsub => get_sub()
43
   call qsub(k)
44
   if (k/=9) call abort
45
end program test
46
 
47
recursive subroutine my_sub(j)
48
   use store_subroutine
49
   implicit none
50
   integer, intent(inout) :: j
51
   j = j*3
52
   call set_sub(my_sub)
53
end subroutine my_sub
54
 
55
! { dg-final { cleanup-modules "store_subroutine" } }
56
 

powered by: WebSVN 2.1.0

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