gcc/testsuite/gfortran.dg/cray_pointers_9.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcray-pointer" }
   3 !
   4 ! Test the fix for PR36703 in which the Cray pointer was not passed
   5 ! correctly so that the call to 'fun' at line 102 caused an ICE.
   6 !
   7 ! Contributed by James van Buskirk on com.lang.fortran
   8 ! http://groups.google.com/group/comp.lang.fortran/msg/b600c081a3654936
   9 ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
  10 !
  11 module funcs
  12    use ISO_C_BINDING           ! Added this USE statement
  13    implicit none
  14 ! Interface block for function program fptr will invoke
  15 ! to get the C_FUNPTR
  16    interface
  17       function get_proc(mess) bind(C,name='BlAh')
  18          use ISO_C_BINDING
  19          implicit none
  20          character(kind=C_CHAR) mess(*)
  21          type(C_FUNPTR) get_proc
  22       end function get_proc
  23    end interface
  24 end module funcs
  25
  26 module other_fun
  27    use ISO_C_BINDING
  28    implicit none
  29    private
  30 ! Message to be returned by procedure pointed to
  31 ! by the C_FUNPTR
  32    character, allocatable, save :: my_message(:)
  33 ! Interface block for the procedure pointed to
  34 ! by the C_FUNPTR
  35    public abstract_fun
  36    abstract interface
  37       function abstract_fun(x)
  38          use ISO_C_BINDING
  39          import my_message
  40          implicit none
  41          integer(C_INT) x(:)
  42          character(size(my_message),C_CHAR) abstract_fun(size(x))
  43       end function abstract_fun
  44    end interface
  45    contains
  46 ! Procedure to store the message and get the C_FUNPTR
  47       function gp(message) bind(C,name='BlAh')
  48          character(kind=C_CHAR) message(*)
  49          type(C_FUNPTR) gp
  50          integer(C_INT64_T) i
  51
  52          i = 1
  53          do while(message(i) /= C_NULL_CHAR)
  54             i = i+1
  55          end do
  56          allocate (my_message(i+1))      ! Added this allocation
  57          my_message = message(int(1,kind(i)):i-1)
  58          gp = get_funloc(make_mess,aux)
  59       end function gp
  60
  61 ! Intermediate procedure to pass the function and get
  62 ! back the C_FUNPTR
  63       function get_funloc(x,y)
  64          procedure(abstract_fun) x
  65          type(C_FUNPTR) y
  66          external y
  67          type(C_FUNPTR) get_funloc
  68
  69          get_funloc = y(x)
  70       end function get_funloc
  71
  72 ! Procedure to convert the function to C_FUNPTR
  73       function aux(x)
  74          interface
  75             subroutine x() bind(C)
  76             end subroutine x
  77          end interface
  78          type(C_FUNPTR) aux
  79
  80          aux = C_FUNLOC(x)
  81       end function aux
  82
  83 ! Procedure pointed to by the C_FUNPTR
  84       function make_mess(x)
  85          integer(C_INT) x(:)
  86          character(size(my_message),C_CHAR) make_mess(size(x))
  87
  88          make_mess = transfer(my_message,make_mess(1))
  89       end function make_mess
  90 end module other_fun
  91
  92 program fptr
  93    use funcs
  94    use other_fun
  95    implicit none
  96    procedure(abstract_fun) fun        ! Removed INTERFACE
  97    pointer(p,fun)
  98    type(C_FUNPTR) fp
  99
 100    fp = get_proc('Hello, world'//achar(0))
 101    p = transfer(fp,p)
 102    write(*,'(a)') fun([1,2,3])
 103 end program fptr