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     use ISO_C_BINDING
  39     integer(C_INT) a(:)
  40     procedure(abs_fun) :: p
  41     character(size(my_message),C_CHAR) :: c(size(a))
  42     integer k,l,m
  43     c = p(a)
  44     m=iachar('a')
  45     do k=1,size(a)
  46       do l=1,size(my_message)
  47         if (c(k)(l:l) /= achar(m)) STOP 1
  48         m = m + 1
  49       end do
  50     end do
  51   end subroutine
  52
  53 end module
  54
  55 program prog
  56
  57 use m
  58
  59 integer(C_INT) :: i(4) = (/0,6,12,18/)
  60
  61 allocate(my_message(1:6))
  62
  63 my_message = (/'a','b','c','d','e','f'/)
  64
  65 call check(foo,i)
  66
  67 end program