1! { dg-do compile }
2! { dg-options "-fcray-pointer" }
3!
4! Test the fix for PR36703 in which the Cray pointer was not passed
5! correctly so that the call to 'fun' at line 102 caused an ICE.
6!
7! Contributed by James van Buskirk on com.lang.fortran
8! http://groups.google.com/group/comp.lang.fortran/msg/b600c081a3654936
9! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
10!
11module funcs
12   use ISO_C_BINDING           ! Added this USE statement
13   implicit none
14! Interface block for function program fptr will invoke
15! to get the C_FUNPTR
16   interface
17      function get_proc(mess) bind(C,name='BlAh')
18         use ISO_C_BINDING
19         implicit none
20         character(kind=C_CHAR) mess(*)
21         type(C_FUNPTR) get_proc
22      end function get_proc
23   end interface
24end module funcs
25
26module other_fun
27   use ISO_C_BINDING
28   implicit none
29   private
30! Message to be returned by procedure pointed to
31! by the C_FUNPTR
32   character, allocatable, save :: my_message(:)
33! Interface block for the procedure pointed to
34! by the C_FUNPTR
35   public abstract_fun
36   abstract interface
37      function abstract_fun(x)
38         use ISO_C_BINDING
39         import my_message
40         implicit none
41         integer(C_INT) x(:)
42         character(size(my_message),C_CHAR) abstract_fun(size(x))
43      end function abstract_fun
44   end interface
45   contains
46! Procedure to store the message and get the C_FUNPTR
47      function gp(message) bind(C,name='BlAh')
48         character(kind=C_CHAR) message(*)
49         type(C_FUNPTR) gp
50         integer(C_INT64_T) i
51
52         i = 1
53         do while(message(i) /= C_NULL_CHAR)
54            i = i+1
55         end do
56	 allocate (my_message(i+1))      ! Added this allocation
57         my_message = message(int(1,kind(i)):i-1)
58         gp = get_funloc(make_mess,aux)
59      end function gp
60
61! Intermediate procedure to pass the function and get
62! back the C_FUNPTR
63      function get_funloc(x,y)
64         procedure(abstract_fun) x
65         type(C_FUNPTR) y
66         external y
67         type(C_FUNPTR) get_funloc
68
69         get_funloc = y(x)
70      end function get_funloc
71
72! Procedure to convert the function to C_FUNPTR
73      function aux(x)
74         interface
75            subroutine x() bind(C)
76            end subroutine x
77         end interface
78         type(C_FUNPTR) aux
79
80         aux = C_FUNLOC(x)
81      end function aux
82
83! Procedure pointed to by the C_FUNPTR
84      function make_mess(x)
85         integer(C_INT) x(:)
86         character(size(my_message),C_CHAR) make_mess(size(x))
87
88         make_mess = transfer(my_message,make_mess(1))
89      end function make_mess
90end module other_fun
91
92program fptr
93   use funcs
94   use other_fun
95   implicit none
96   procedure(abstract_fun) fun        ! Removed INTERFACE
97   pointer(p,fun)
98   type(C_FUNPTR) fp
99
100   fp = get_proc('Hello, world'//achar(0))
101   p = transfer(fp,p)
102   write(*,'(a)') fun([1,2,3])
103end program fptr
104