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