69 lines
1.2 KiB
Fortran
69 lines
1.2 KiB
Fortran
! { 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
|
|
|
|
! { dg-final { cleanup-modules "m" } }
|