1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
! { dg-do run }
!
! PR 36322/36463
!
! Original code by James Van Buskirk.
! Modified by Janus Weil <janus@gcc.gnu.org>
module m
use ISO_C_BINDING
character, allocatable, save :: my_message(:)
abstract interface
function abs_fun(x)
use ISO_C_BINDING
import my_message
integer(C_INT) x(:)
character(size(my_message),C_CHAR) abs_fun(size(x))
end function abs_fun
end interface
contains
function foo(y)
implicit none
integer(C_INT) :: y(:)
character(size(my_message),C_CHAR) :: foo(size(y))
integer i,j
do i=1,size(y)
do j=1,size(my_message)
foo(i)(j:j) = achar(iachar(my_message(j))+y(i))
end do
end do
end function
subroutine check(p,a)
integer a(:)
procedure(abs_fun) :: p
character(size(my_message),C_CHAR) :: c(size(a))
integer k,l,m
c = p(a)
m=iachar('a')
do k=1,size(a)
do l=1,size(my_message)
if (c(k)(l:l) /= achar(m)) call abort()
m = m + 1
end do
end do
end subroutine
end module
program prog
use m
integer :: i(4) = (/0,6,12,18/)
allocate(my_message(1:6))
my_message = (/'a','b','c','d','e','f'/)
call check(foo,i)
end program
|
