gcc/testsuite/gfortran.dg/proc_decl_17.f90

   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
   8 module 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
  23 contains
  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
  52 end module
  53
  54 program prog
  55
  56 use m
  57
  58 integer :: i(4) = (/0,6,12,18/)
  59
  60 allocate(my_message(1:6))
  61
  62 my_message = (/'a','b','c','d','e','f'/)
  63
  64 call check(foo,i)
  65
  66 end program