2 ! { dg-options "-fcray-pointer" }
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.
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>
12 use ISO_C_BINDING ! Added this USE statement
14 ! Interface block for function program fptr will invoke
17 function get_proc(mess) bind(C,name='BlAh')
20 character(kind=C_CHAR) mess(*)
21 type(C_FUNPTR) get_proc
30 ! Message to be returned by procedure pointed to
32 character, allocatable, save :: my_message(:)
33 ! Interface block for the procedure pointed to
37 function abstract_fun(x)
42 character(size(my_message),C_CHAR) abstract_fun(size(x))
43 end function abstract_fun
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(*)
53 do while(message(i) /= C_NULL_CHAR)
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)
61 ! Intermediate procedure to pass the function and get
63 function get_funloc(x,y)
64 procedure(abstract_fun) x
67 type(C_FUNPTR) get_funloc
70 end function get_funloc
72 ! Procedure to convert the function to C_FUNPTR
75 subroutine x() bind(C)
83 ! Procedure pointed to by the C_FUNPTR
86 character(size(my_message),C_CHAR) make_mess(size(x))
88 make_mess = transfer(my_message,make_mess(1))
89 end function make_mess
96 procedure(abstract_fun) fun ! Removed INTERFACE
100 fp = get_proc('Hello, world'//achar(0))
102 write(*,'(a)') fun([1,2,3])